Index: Makefile.in =================================================================== diff -u -r92e6424562685bcc3665bf23dfcdc3ee489c25ef -r8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 --- Makefile.in (.../Makefile.in) (revision 92e6424562685bcc3665bf23dfcdc3ee489c25ef) +++ Makefile.in (.../Makefile.in) (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -388,22 +388,22 @@ #TESTFLAGS = -srcdir $(srcdir) test-core: $(TCLSH_PROG) - $(TCLSH) $(src_test_dir_native)/object-system.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/destroytest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/method-modifiers.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/var-access.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/varresolutiontest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/info-method.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/submethods.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/parameters.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/returns.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/method-require.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/interceptor-slot.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/aliastest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/protected.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/forwardtest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/mixinoftest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/tcl86.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/object-system.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/destroy.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/method-modifiers.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/var-access.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/varresolution.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/info-method.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/submethods.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/parameters.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/returns.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/method-require.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/interceptor-slot.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/alias.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/protected.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/forward.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/mixinof.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/tcl86.test -libdir $(PLATFORM_DIR) $(TESTFLAGS) test-xotcl: $(TCLSH_PROG) $(TCLSH) $(xotcl_src_test_dir)/testo.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) Index: TODO =================================================================== diff -u -r440e05aa8a59891a119c4fd5fa3ad4193cedd9a3 -r8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 --- TODO (.../TODO) (revision 440e05aa8a59891a119c4fd5fa3ad4193cedd9a3) +++ TODO (.../TODO) (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -1818,6 +1818,7 @@ such as "Object public method foo {} {}" - removed defaultMethodCallProtection in alias test - extended regression tests for aliases to procs +- renamed nx regression tests .test to follow tcl conventions TODO: Index: tests/alias.test =================================================================== diff -u --- tests/alias.test (revision 0) +++ tests/alias.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,546 @@ +# -*- Tcl -*- +package require nx; namespace import -force ::nx::* +#::nx::configure defaultMethodCallProtection false +package require nx::test + +Test parameter count 10 +Test case alias-preliminaries { + + # The system methods of Object are either alias or forwarders + ? {lsort [::nx::ObjectParameterSlot info methods -methodtype alias]} {assign get} + ? {::nx::ObjectParameterSlot info method definition get} \ + "::nx::ObjectParameterSlot public alias get ::nsf::setvar" + + # define an alias and retrieve its definition + set cmd "::nx::Object public alias set ::set" + eval $cmd + ? {Object info method definition set} $cmd + + # define an alias and retrieve its definition + set cmd "::nx::Object public alias set -frame method ::set" + eval $cmd + ? {Object info method definition set} $cmd + + # define an alias and retrieve its definition + set cmd "::nx::Object public alias set -frame object ::set" + eval $cmd + ? {Object info method definition set} $cmd + + proc ::foo {} {return foo} + ? {Object alias foo -frame object ::foo} \ + "cannot use -frame object|method in alias for scripted command '::foo'" + ? {Object alias foo -frame method ::foo} \ + "cannot use -frame object|method in alias for scripted command '::foo'" + ? {Object alias foo -frame default ::foo} "::nsf::classes::nx::Object::foo" + +} + +Test case alias-simple { + # define an alias and retrieve its definition + Class create Base { + :public method foo {{-x 1}} {return $x} + } + + Class create Foo + ? {::nsf::alias ::Foo foo ::nsf::classes::Base::foo} "::nsf::classes::Foo::foo" + + ? {Foo info method definition foo} "::Foo public alias foo ::nsf::classes::Base::foo" + + Foo create f1 + ? {f1 foo} 1 + ? {f1 foo -x 2} 2 + ? {Foo info methods -methodtype alias} "foo" + + ? {Base info methods -methodtype scripted} {foo} + ? {Foo info methods -methodtype scripted} {} + ? {Foo info methods -methodtype alias} {foo} + Base public method foo {} {} + ? {Foo info methods -methodtype alias} "" + ? {Base info methods -methodtype scripted} {} + ? {Foo info methods -methodtype scripted} {} + ? {Foo info method definition foo} "" + + + Base public method foo {{-x 1}} {return $x} + ::nsf::alias ::Foo foo ::nsf::classes::Base::foo + + ? {Base info methods -methodtype scripted} {foo} "defined again" + ? {Foo info methods -methodtype alias} {foo} "aliased again" + Foo public method foo {} {} + ? {Base info methods -methodtype scripted} {foo} "still defined" + ? {Foo info methods -methodtype alias} {} "removed" +} + +Test case alias-chaining { + # + # chaining aliases + # + + Class create T + Class create S + T create t + S create s + + + T public method foo args { return [current class]->[current method] } + ::nsf::alias T FOO ::nsf::classes::T::foo + + ? {t foo} ::T->foo + ? {t FOO} ::T->foo + + ? {lsort [T info methods]} {FOO foo} + T method foo {} {} + ? {lsort [T info methods]} {} "alias is deleted" + + # puts stderr "double indirection" + T public method foo args { return [current class]->[current method] } + ::nsf::alias T FOO ::nsf::classes::T::foo + ::nsf::alias S BAR ::nsf::classes::T::FOO + + ? {T info methods -methodtype alias} "FOO" + ? {T info method definition FOO} "::T public alias FOO ::nsf::classes::T::foo" + ? {lsort [T info methods]} {FOO foo} + ? {S info methods} {BAR} + T method FOO {} {} + ? {T info methods} {foo} + ? {S info methods} {BAR} + ? {s BAR} ::S->foo + ? {t foo} ::T->foo + ? {S info method definition BAR} "::S public alias BAR ::nsf::classes::T::FOO" + + + T public method foo {} {} + ? {T info methods} {} + ? {S info methods} {} + + T public method foo args { return [current class]->[current method] } + ::nsf::alias T FOO ::nsf::classes::T::foo + ::nsf::alias S BAR ::nsf::classes::T::FOO + + ? {lsort [T info methods]} {FOO foo} + ? {S info methods} {BAR} + T public method foo {} {} + ? {S info methods} {} + ? {T info methods} {} + + T public method foo args { return [current class]->[current method] } + T public class-object method bar args { return [current class]->[current method] } + ::nsf::alias T -per-object FOO ::nsf::classes::T::foo + ::nsf::alias T -per-object BAR ::T::FOO + ::nsf::alias T -per-object ZAP ::T::BAR + ? {T info methods} {foo} + ? {lsort [T class-object info methods -methodtype alias]} {BAR FOO ZAP} + ? {lsort [T class-object info methods]} {BAR FOO ZAP bar} + ? {t foo} ::T->foo + ? {T class-object info method definition ZAP} {::T public class-object alias ZAP ::T::BAR} + + ? {T FOO} ->foo + ? {T BAR} ->foo + ? {T ZAP} ->foo + ? {T bar} ->bar + T class-object method FOO {} {} + ? {T info methods} {foo} + ? {lsort [T class-object info methods]} {BAR ZAP bar} + ? {T BAR} ->foo + ? {T ZAP} ->foo + rename ::T::BAR "" + ? {T info methods} {foo} + ? {lsort [T class-object info methods]} {ZAP bar} + #? {T BAR} ""; # now calling the proc defined above, alias chain seems intact + ? {T ZAP} ->foo; # is ok, still pointing to 'foo' + #T class-object method BAR {} {} + ? {T info methods} {foo} + ? {lsort [T class-object info methods]} {ZAP bar} + ? {T ZAP} ->foo + T public method foo {} {} + ? {T info methods} {} + ? {lsort [T class-object info methods]} {bar} +} + +Test case alias-per-object { + + Class create T { + :public class-object method bar args { return [current class]->[current method] } + :create t + } + proc ::foo args { return [current class]->[current method] } + + # + # per-object methods as per-object aliases + # + T public class-object method m1 args { return [current class]->[current method] } + ::nsf::alias T -per-object M1 ::T::m1 + ::nsf::alias T -per-object M11 ::T::M1 + ? {lsort [T class-object info methods]} {M1 M11 bar m1} + ? {T m1} ->m1 + ? {T M1} ->m1 + ? {T M11} ->m1 + T class-object method M1 {} {} + ? {lsort [T class-object info methods]} {M11 bar m1} + ? {T m1} ->m1 + ? {T M11} ->m1 + T class-object method m1 {} {} + ? {lsort [T class-object info methods]} {bar} + + # + # a proc as alias + # + + proc foo args { return [current class]->[current method] } + ::nsf::alias T FOO1 ::foo + ::nsf::alias T -per-object FOO2 ::foo + # + # ! per-object alias referenced as per-class alias ! + # + ::nsf::alias T BAR ::T::FOO2 + ? {lsort [T class-object info methods]} {FOO2 bar} + ? {lsort [T info methods]} {BAR FOO1} + ? {T FOO2} ->foo + ? {t FOO1} ::T->foo + ? {t BAR} ::T->foo + # + # delete proc + # + rename ::foo "" + ? {lsort [T class-object info methods]} {bar} + ? {lsort [T info methods]} {} +} + + +# namespaced procs + namespace deletion +Test case alias-namespaced { + Class create T { + :public class-object method bar args { return [current class]->[current method] } + :create t + } + + namespace eval ::ns1 { + proc foo args { return [current class]->[current method] } + proc bar args { return [uplevel 2 {set _}] } + proc bar2 args { upvar 2 _ __; return $__} + } + + ::nsf::alias T FOO ::ns1::foo + ::nsf::alias T BAR ::ns1::bar + ::nsf::alias T BAR2 ::ns1::bar2 + ? {lsort [T info methods]} {BAR BAR2 FOO} + set ::_ GOTYA + ? {t FOO} ::T->foo + ? {t BAR} GOTYA + ? {t BAR2} GOTYA + namespace delete ::ns1 + ? {info procs ::ns1::*} {} + ? {lsort [T info methods]} {} + + # per-object namespaces + + Class create U + U create u + ? {namespace exists ::U} 0 + U public class-object method zap args { return [current class]->[current method] } + ::nsf::alias ::U -per-object ZAP ::U::zap + U require namespace + ? {namespace exists ::U} 1 + + U public class-object method bar args { return [current class]->[current method] } + ::nsf::alias U -per-object BAR ::U::bar + ? {lsort [U class-object info methods]} {BAR ZAP bar zap} + ? {U BAR} ->bar + ? {U ZAP} ->zap + namespace delete ::U + ? {namespace exists ::U} 0 + ? {lsort [U class-object info methods]} {} + ? {U info lookup methods BAR} "" + ? {U info lookup methods ZAP} "" + + ::U destroy +} + +# dot-resolver/ dot-dispatcher used in aliased proc + +Test case alias-dot-resolver { + + Class create V { + set :z 1 + :public method bar {z} { return $z } + :public class-object method bar {z} { return $z } + :create v { + set :z 2 + } + } + ? {lsort [V info vars]} {z} + + ? {lsort [V info vars]} {z} + ? {lsort [v info vars]} {z} + + proc ::foo args { return [:bar ${:z}]-[set :z]-[:bar [set :z]] } + + ::nsf::alias V FOO1 ::foo + ::nsf::alias V -per-object FOO2 ::foo + + ? {lsort [V class-object info methods]} {FOO2 bar} + ? {lsort [V info methods]} {FOO1 bar} + + ? {V FOO2} 1-1-1 + ? {v FOO1} 2-2-2 + V public method FOO1 {} {} + ? {lsort [V info methods]} {bar} + rename ::foo "" + ? {lsort [V class-object info methods]} {bar} +} + +# +# Tests for the ::nsf::alias store, used for introspection for +# aliases. The alias store (an associative variable) is mostly +# necessary for for the direct aliases (e.g. aliases to C implemented +# tcl commands), for which we have no stubs at the place where the +# alias was registered. +# + +# +# structure of the ::nsf::alias store: +# ,, -> +# + +Object create o +Class create C + +o public method bar args {;} + +? {info vars ::nsf::alias} ::nsf::alias +? {array exists ::nsf::alias} 1 + +proc ::foo args {;} +::nsf::alias ::o FOO ::foo +::nsf::alias ::C FOO ::foo +? {info exists ::nsf::alias(::o,FOO,1)} 1 +? {info exists ::nsf::alias(::C,FOO,0)} 1 +? {array get ::nsf::alias ::o,FOO,1} "::o,FOO,1 ::foo" +? {array get ::nsf::alias ::C,FOO,0} "::C,FOO,0 ::foo" +? {o info method definition FOO} "::o public alias FOO ::foo" +? {C info method definition FOO} "::C public alias FOO ::foo" + +::nsf::alias o FOO ::o::bar +? {info exists ::nsf::alias(::o,FOO,1)} 1 +? {array get ::nsf::alias ::o,FOO,1} "::o,FOO,1 ::o::bar" +? {o info method definition FOO} "::o public alias FOO ::o::bar" + +# AliasDelete in XOTclRemoveObjectMethod +o public method FOO {} {} +? {info exists ::nsf::alias(::o,FOO,1)} 0 +? {array get ::nsf::alias ::o,FOO,1} "" +? {o info method definition FOO} "" + +# AliasDelete in XOTclRemoveClassMethod +C public method FOO {} {} +? {info exists ::nsf::alias(::C,FOO,0)} 0 +? {array get ::nsf::alias ::C,FOO,0} "" +? {C info method definition FOO} "" + +::nsf::alias ::o BAR ::foo +::nsf::alias ::C BAR ::foo + +# AliasDelete in XOTclAddObjectMethod +? {info exists ::nsf::alias(::o,BAR,1)} 1 +::o public method BAR {} {;} +? {info exists ::nsf::alias(::o,BAR,1)} 0 + +# AliasDelete in XOTclAddInstanceMethod +? {info exists ::nsf::alias(::C,BAR,0)} 1 +::C public method BAR {} {;} +? {info exists ::nsf::alias(::C,BAR,0)} 0 + +# AliasDelete in aliasCmdDeleteProc +::nsf::alias o FOO ::foo +? {info exists ::nsf::alias(::o,FOO,1)} 1 +rename ::foo "" +? {info exists ::nsf::alias(::o,FOO,1)} 0 + +::nsf::alias o FOO ::o::bar +::nsf::alias o BAR ::o::FOO +? {info exists ::nsf::alias(::o,FOO,1)} 1 +? {info exists ::nsf::alias(::o,BAR,1)} 1 +o public method bar {} {} +? {info exists ::nsf::alias(::o,FOO,1)} 0 +? {info exists ::nsf::alias(::o,BAR,1)} 0 + +# +# pulling the rug out from the proc-alias deletion mechanism +# + +proc ::foo args {;} +::nsf::alias C FOO ::foo +? {info exists ::nsf::alias(::C,FOO,0)} 1 +unset ::nsf::alias(::C,FOO,0) +? {info exists ::nsf::alias(::C,FOO,0)} 0 +? {C info method definition FOO} "" +? {C info methods -methodtype alias} FOO +rename ::foo "" +? {C info methods -methodtype alias} "" +? {info exists ::nsf::alias(::C,FOO,0)} 0 +? {C info method definition FOO} "" + +# +# test renaming of Tcl proc (actually sensed by the alias, though not +# reflected by the alias definition store) +# a) is this acceptable? +# b) sync ::nsf::alias upon "info method definition" calls? is this feasible, +# e.g. through rename traces? +# + +C create c +proc ::foo args { return [current]->[current method]} +? {info exists ::nsf::alias(::C,FOO,0)} 0 +::nsf::alias C FOO ::foo +? {info exists ::nsf::alias(::C,FOO,0)} 1 +? {C info methods -methodtype alias} FOO +rename ::foo ::foo2 +? {info exists ::nsf::alias(::C,FOO,0)} 1 +? {C info methods -methodtype alias} FOO +? {c FOO} ::c->foo2 +? {C info method definition FOO} "::C public alias FOO ::foo"; # should be ::foo2 (!) + + +# +# Check resolving of namespace imported classes +# and when a class is aliased via "interp alias" +# +Test case class-resolve { + namespace eval ::ns1 { + nx::Class create A {:public method foo {} {::nx::current class}} + nx::Class create B {:public method foo {} {::nx::current class}} + namespace export A + } + + namespace eval ::ns2 { + # namespace import Class A from namespace ns1 + namespace import ::ns1::A + ? {A create a1} ::ns2::a1 + ? {nx::Class create C -superclass A} ::ns2::C + ? {C create c1} ::ns2::c1 + ? {c1 foo} ::ns1::A + + # "import" Class B from namespace ns1 via interp-alias + interp alias {} ::ns2::B {} ::ns1::B + ? {B create b1} ::ns2::b1 + ? {b1 foo} ::ns1::B + ? {nx::Class create D -superclass B} ::ns2::D + ? {D create d1} ::ns2::d1 + ? {d1 foo} ::ns1::B + } +} + +Test parameter count 10 +Test case proc-alias { + + nx::Class create C { + :public method foo {} {upvar x y; info exists y} + :public method bar {} {set x 1; :foo} + + :public alias bar_ [:info method handle bar] + :public alias foo_ [:info method handle foo] + :public method bar2 {} {set x 1; :foo_} + + :create c1 + } + + nx::Class create D { + :public method foo {} {:upvar x y; info exists y} + :public method bar {} {set x 1; :foo} + + :public alias foo_ [:info method handle foo] + :public alias bar_ [:info method handle bar] + :public method bar2 {} {set x 1; :foo_} + + :create d1 + } + + nx::Class create M { + :public method foo args next + :public method bar args next + :public method foo_ args next + :public method bar_ args next + :public method bar_ args next + } + + ? {c1 bar} 1 + ? {c1 bar_} 1 + ? {c1 bar2} 0 ;# upvar reaches into to alias-redirector + + ? {d1 bar} 1 + ? {d1 bar_} 1 + ? {d1 bar2} 1 + + c1 mixin add M + + ? {c1 bar} 0 ;# upvar reaches into to mixin method + ? {c1 bar_} 0 ;# upvar reaches into to mixin method + ? {c1 bar2} 0 ;# upvar reaches into to mixin method + + d1 mixin add M + + ? {d1 bar} 1 + ? {d1 bar_} 1 + ? {d1 bar2} 1 + +} + +proc foo {:a :b} { + set :c 1 + return ${:a} +} +foo 1 2 + +proc bar {:a :b} { + set :b 1 + set :x 47 + return [info exists :d]-${:a}-${:x} +} + +proc baz {} { + set :z 3 + return ${:z} +} + +Test parameter count 10 +Test case proc-alias-compile { + + Object create o { + set :a 100 + set :d 1001 + #:method foo {-:a:integer :b :c:optional} { + # puts stderr ${:a},${:b},${:c} + #} + :public alias foo ::foo + :public alias bar ::bar + :public alias baz ::baz + } + + # + # by calling "foo" outside the obejct/method context, we get a + # byte-code without the compiled-local handler, colon-vars are not + # recognized, :a refers to the argument + ? {foo 1 2} 1 + ? {lsort [o info vars]} "a d" + + ? {o foo 1 2} 1 + ? {lsort [o info vars]} "a d" + + # + # by calling "bar" the first time as a method, we get a byte-code with + # the compiled-local handler, colon-vars are recognized, colon vars + # from the argument vector have precedence over instance variables. + ? {o bar 2 3} 1-2-47 + ? {lsort [o info vars]} "a d x" + + ? {o baz} 3 + ? {lsort [o info vars]} "a d x z" + # + # by calling "bar" outside the proc context, the compiled-var-fetch + # has no object to refer to, the variable is unknown. + ? {bar 3 4} 0-3-47 + + # the variable in the test scope does not influence result + set :d 200 + ? {bar 3 4} 0-3-47 +} \ No newline at end of file Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/aliastest.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/destroy.test =================================================================== diff -u --- tests/destroy.test (revision 0) +++ tests/destroy.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,634 @@ +# -*- Tcl -*- +package require nx; namespace import ::nx::* +::nx::configure defaultMethodCallProtection false +package require nx::test + +Test parameter count 10 + +::nsf::alias ::nx::Object set -frame object ::set + +Class create O -superclass Object { + :method init {} { + set ::ObjectDestroy 0 + set ::firstDestroy 0 + } + :method destroy {} { + incr ::ObjectDestroy + #[:info class] dealloc [current] + next + } +} + +# +# classical simple case +# +set case "simple destroy (1)" +Test case simple-destroy-1 +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + :destroy + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + ? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBBB" + ? {::nsf::isobject c1} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" +} +C create c1 +c1 foo + +? {::nsf::isobject c1} 0 "$::case object deleted" +? "set ::firstDestroy" 1 "firstDestroy called" + + +# +# simple case, destroy does not propagate, c1 survives +# +set case "simple destroy (2), destroy blocks" +Test case simple-destroy-2 +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} +C method foo {} { + puts stderr "==== $::case [current]" + :destroy + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + ? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBBB" + ? {::nsf::isobject c1} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo + +? {::nsf::isobject c1} 1 "$::case object deleted" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 0 "ObjectDestroy called" + +# +# simple object recreate +# +set case "recreate" +Test case recreate +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + [:info class] create [current] + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + ? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBBB" + ? {::nsf::isobject c1} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo + +? {::nsf::isobject c1} 1 "$::case object deleted" +? "set ::firstDestroy" 0 "firstDestroy called" + +# +# cmd rename to empty, xotcl provides its own rename and calls destroy +# .. like simple case above +# +set case "cmd rename empty (1)" +Test case rename-empty-1 +Object create o +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + rename [current] "" + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + ? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + ? {::nsf::isobject c1} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" +} +C create c1 +c1 foo + +? {::nsf::isobject c1} 0 "$::case object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "ObjectDestroy called" + +# +# cmd rename to empty, xotcl provides its own rename and calls +# destroy, but destroy does not propagate, c1 survives rename, since +# this is the situation like above, as long xotcl's rename is used. +# +set case "cmd rename empty (2)" +Test case rename-empty-2 +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} +C method foo {} { + puts stderr "==== $::case [current]" + rename [current] "" + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + ? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + ? {::nsf::isobject c1} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo + +#puts stderr ======[c1 set x] +? {::nsf::isobject c1} 1 "$::case object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 0 "ObjectDestroy called" + +# +# cmd rename other xotcl object to current, +# xotcl's rename invokes a move +# +set case "cmd rename object to current" +Test case rename-to-current +Object create o +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + rename o [current] + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + ? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + ? {::nsf::isobject c1} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo + +? {::nsf::isobject c1} 1 "$::case object still exists after proc" +? "set ::firstDestroy" 0 "firstDestroy called" +? "set ::ObjectDestroy" 0 "ObjectDestroy called" + +# +# cmd rename other proc to current object, +# xotcl's rename invokes a move +# +set case "cmd rename proc to current" +Test case rename-proc-to-current +proc o args {} +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + set x [catch {rename o [current]}] + ? "set _ $x" 1 "$::case tcl refuses to rename into an existing command" +} +C create c1 +c1 foo +? {::nsf::isobject c1} 1 "$::case object still exists after proc" +? "set ::firstDestroy" 0 "firstDestroy called" +? "set ::ObjectDestroy" 0 "ObjectDestroy called" + + +# +# namespace delete: tcl delays delete until the namespace is not +# active anymore. destroy is called after BBBB. Hypothesis: destroy is +# called only when we are lucky, since C might be destroyed before c1 +# by the namespace delete +# + +set case "delete parent namespace (1)" +Test case delete-parent-namespace +namespace eval ::test { + Class create C -superclass O + C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} + C method foo {} { + puts stderr "==== $::case [current]" + namespace delete ::test + + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + # + # If the following line is commented in, the namespace is deleted + # here. Is there a bug with nsPtr->activationCount + # + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + puts stderr "???? [current] exists [::nsf::isobject [current]]" + ? "::nsf::isobject [current]" 0 ;# WHY? + puts stderr "???? [current] exists [::nsf::isobject [current]]" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "$::case destroy not yet called" + } +} +test::C create test::c1 +test::c1 foo + +? {::nsf::isobject test::c1} 0 "object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "destroy was called when poping stack frame" +? {::nsf::isobject ::test::C} 0 "class still exists after proc" +? {namespace exists ::test::C} 0 "namespace ::test::C still exists after proc" +? {namespace exists ::test} 1 "parent ::test namespace still exists after proc" +? {namespace exists ::xotcl::classes::test::C} 0 "namespace ::xotcl::classes::test::C still exists after proc" + +# +# namespace delete: tcl delays delete until the namespace is not +# active anymore. destroy is called after BBBB, but does not +# propagate. +# +set case "delete parent namespace (2)" +Test case delete-parent-namespace-2 +namespace eval ::test { + ? {namespace exists test::C} 0 "exists test::C" + Class create C -superclass O + C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} + C method foo {} { + puts stderr "==== $::case [current]" + namespace delete ::test + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + # + # If the following line is commented in, the namespace is deleted + # here. Is there a bug with nsPtr->activationCount + # + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBBB" + puts stderr "???? [current] exists [::nsf::isobject [current]]" + ? "::nsf::isobject [current]" 0 "$::case object still exists in proc";# WHY? + puts stderr "???? [current] exists [::nsf::isobject [current]]" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called"; # NOT YET CALLED + } +} +test::C create test::c1 +test::c1 foo + +? {::nsf::isobject test::c1} 0 "$::case object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 0 "ObjectDestroy called" ;# toplevel destroy was blocked + +# +# controlled namespace delete: xotcl has its own namespace cleanup, +# topological order should be always ok. however, the object o::c1 is +# already deleted, while a method of it is excuted +# +set case "delete parent object (1)" +Test case delete-parent-object +Object create o +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + o destroy + puts stderr "AAAA" + # the following isobject call has a problem in Tcl_GetCommandFromObj(), + # which tries to access invalid memory + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBBB" + ? {::nsf::isobject ::o::c1} 0 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" +} +C create o::c1 +o::c1 foo + +? {::nsf::isobject ::o::c1} 0 "$::case object o::c1 still exists after proc" +? {::nsf::isobject o} 0 "$::case object o still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "ObjectDestroy called" + +# +# controlled namespace delete: xotcl has its own namespace cleanup. +# destroy does not delegate, but still o::c1 does not survive, since o +# is deleted. +# +set case "delete parent object (2)" +Test case delete-parent-object-2 +Object create o +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy block"} +C method foo {} { + puts stderr "==== $::case [current]" + o destroy + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + ? {::nsf::isobject ::o::c1} 0 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create o::c1 +o::c1 foo + +? {::nsf::isobject ::o::c1} 0 "$::case object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 0 "ObjectDestroy called" + + +# +# create an other cmd with the current object's name. +# xotcl 1.6 crashed on this test +# +set case "redefined current object as proc" +Test case redefined-current-object-as-proc +Object create o +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + proc [current] {args} {puts HELLO} + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" + ? {::nsf::isobject c1} 0 "$::case object still exists in proc" +} +C create c1 +c1 foo + +? {::nsf::isobject c1} 0 "$::case object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "ObjectDestroy called" + + + +# +# delete the active class +# +set case "delete active class" +Test case delete-active-class +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + C destroy + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + #? [:info class] ::xotcl::Object "object reclassed" + ? [:info class] ::C "object reclassed?" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" + ? {::nsf::isobject c1} 1 "object still exists in proc" + #? {::nsf::is class ::C} 0 "class still exists in proc" + ? {::nsf::is class ::C} 1 "class still exists in proc" +} +C create c1 +c1 foo + +? {::nsf::isobject c1} 1 "object still exists after proc" +? [c1 info class] ::nx::Object "after proc: object reclassed?" +? "set ::firstDestroy" 0 "firstDestroy called" +? "set ::ObjectDestroy" 0 "ObjectDestroy called" + +# +# delete active object nested in class +# +set case "delete active object nested in class" +Test case delete-active-object-nested-in-class +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} +C method foo {} { + puts stderr "==== $::case [current]" + C destroy + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + #? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::firstDestroy" 1 "firstDestroy called" + #? "set ::ObjectDestroy" 0 "ObjectDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" + ? [:info class] ::C "object reclassed" + #? [:info class] ::xotcl::Object "object reclassed" + ? {::nsf::isobject ::C::c1} 1 "object still exists in proc" + ? {::nsf::is class ::C} 1 "class still exists in proc" +} +C create ::C::c1 +C::c1 foo +#puts stderr ======[::nsf::isobject ::C::c1] +? {::nsf::isobject ::C::c1} 0 "object still exists after proc" +? {::nsf::is class ::C} 0 "class still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "ObjectDestroy called" + +# +Test case nesting-destroy { + Object create x + Object create x::y + x destroy + ? {::nsf::isobject x} 0 "parent object gone" + ? {::nsf::isobject x::y} 0 "child object gone" +} + +Test case deleting-aliased-object { + Object create o + Object create o2 + ::nsf::alias o a o2 + ? {o a} ::o2 "call object via alias" + ? {o info method type a} alias + ## the ensemble-object needs per-object methods + o2 method info args {:info {*}$args} + o2 method set args {:set {*}$args} + ? {o a info vars} "" "call info on aliased object" + ? {o set x 10} 10 "set variable on object" + ? {o info vars} x "query vars" + ? {o a info vars} x "query vars via alias" + ? {o a set x} 10 "set var via alias" + o2 destroy + ? {o a info vars} "Trying to dispatch deleted object via method 'a'" "1st call on deleted object" + ? {o a info vars} "::o: unable to dispatch method 'a'" "2nd call on deleted object" +} + +set case "deleting object with alias to object" +Test case deleting-object-with-alias-to-object +Object create o +Object create o3 +::nsf::alias o x o3 +o destroy +? {::nsf::isobject o} 0 "parent object gone" +? {::nsf::isobject o3} 1 "aliased object still here" +o3 destroy +? {::nsf::isobject o3} 0 "aliased object destroyed" + +set case "create an alias, and delete cmd via aggregation" +Test case create-alias-delete-via-aggregation +Object create o +Object create o3 +::nsf::alias o x o3 +o::x destroy +? {::nsf::isobject o3} 0 "aliased object destroyed" +o destroy + +# +# create an alias, and recreate obj +# +Test case create-alias-and-recreate-obj { + Object create o + Object create o3 + o alias x o3 + Object create o3 + o3 method set args {:set {*}$args} + o set a 13 + ? {o x set a} 13 "aliased object works after recreate" +} + +# +# create an alias on the class level, double aliasing, delete aliased +# object +# +Test case create-alias-on-class-delete-aliased-obj { + Class create C + Object create o + Object create o3 + o alias a o3 + C alias b o + + o3 method set args {:set {*}$args} + o method set args {:set {*}$args} + + C create c1 + ? {c1 b set B 2} 2 "call 1st level" + ? {c1 b a set A 3} 3 "call 2nd level" + + ? {c1 set B} 2 "call 1st level ok" + ? {c1 set A} 3 "call 2nd level ok" + o destroy + ? {c1 b} "Trying to dispatch deleted object via method 'b'" "call via alias to deleted object" +} + +# +# create an alias on the class level, double aliasing, destroy class +# +Test case create-alias-on-class-destroy-class { + Class create C + Object create o + Object create o3 + o alias a o3 + C alias b o + C create c1 + C destroy + ? {::nsf::isobject o} 1 "object o still here" + ? {::nsf::isobject o3} 1 "object o3 still here" +} + +# +# test cases where preexisting namespaces are re-used +# + +Test case module { + # create a namespace with an object/class in it + namespace eval ::module { Object create foo } + + # reuse the namespace for a class/object + Class create ::module + + ? {::nsf::is class ::module} 1 + + # delete the object/class ... and namespace + ::module destroy + + ? {::nsf::is class ::module} 0 +} + +Test case namespace-import { + + namespace eval ::module { + Class create Foo { + :create foo + } + namespace export Foo foo + } + Class create ::module { + :create mod1 + } + ? {::nsf::is class ::module::Foo} 1 + ? {::nsf::is class ::module::foo} 0 + ? {::nsf::isobject ::module::foo} 1 + ? {::nsf::is class ::module} 1 + + Object create ::o { :require namespace } + namespace eval ::o {namespace import ::module::*} + + ? {::nsf::is class ::o::Foo} 1 + ? {::nsf::isobject ::o::foo} 1 + + # do not destroy namespace imported objects/classes + ::o destroy + + ? {::nsf::is class ::o::Foo} 0 + ? {::nsf::isobject ::o::foo} 0 + + ? {::nsf::is class ::module::Foo} 1 + ? {::nsf::isobject ::module::foo} 1 + + ::module destroy +} + +# to avoid CallDirectly, we could activate this line +::nx::Class create M {:method dealloc args {next}} +Test case delete-parent-namespace-dealloc +namespace eval ::test { + Class create C -superclass O + C method destroy {} {incr ::firstDestroy; puts stderr " *** [current] destroy"; next} + C method foo {} { + puts stderr "==== $::case [current]" + namespace delete ::test + puts stderr "AAAA [current] exists [::nsf::isobject [current]]" + :set x 1 + # + # If the following line is commented in, the namespace is deleted + # here. Is there a bug with nsPtr->activationCount + # + #? "[current] set x" 1 "$::case can still access [current]" + puts stderr "BBB" + puts stderr "???? [current] exists [::nsf::isobject [current]]" + ? "::nsf::isobject [current]" 0 ;# WHY? + puts stderr "???? [current] exists [::nsf::isobject [current]]" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "$::case destroy not yet called" + } +} +test::C create test::c1 +test::c1 foo +? {::nsf::isobject test::c1} 0 "object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "destroy was called when poping stack frame" +? {::nsf::isobject ::test::C} 0 "class still exists after proc" +? {namespace exists ::test::C} 0 "namespace ::test::C still exists after proc" +? {namespace exists ::test} 1 "parent ::test namespace still exists after proc" +? {namespace exists ::xotcl::classes::test::C} 0 "namespace ::xotcl::classes::test::C still exists after proc" + +puts stderr "==== EXIT ====" +exit + +TODO: +fix crashes in regression test: DONE, + -> well we can't call traceprocs on the object being destroyed; maybe call CleanupDestroyObject() ealier + move destroy logic to activationCount DONE + simplify logic (remove callIsDestroy, callstate XOTCL_CSC_CALL_IS_DESTROY, destroyedCmd on stack content) DONE + remove CallStackMarkDestroyed(), CallStackMarkUndestroyed() DONE + remove traces of rst->callIsDestroy DONE + revive tclStack (without 85) DONE + check state changes DONE + delete active class; maybe C destroy, c1 destroy (or C::c1 + C destroy) DONE + add recreate logic test case DONE + +more generic */ +XOTCLINLINE static Tcl_ObjType * +GetCmdNameType(Tcl_ObjType *cmdType) { + + MATRIX \ No newline at end of file Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/destroytest.tcl'. Fisheye: No comparison available. Pass `N' to diff? Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/doc.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/doc.test =================================================================== diff -u --- tests/doc.test (revision 0) +++ tests/doc.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,1144 @@ +# -*- Tcl -*- +package require nx +package require nx::test +package require nx::doc + +namespace import -force ::nx::* +namespace import -force ::nx::doc::* + + +Test parameter count 1 + +# +# some helper +# + +proc lcompare {a b} { + foreach x $a y $b { + if {$a ne $b} { + return -1; break; + } + } + return 1 +} + +# -- + +Test case scanning { + + set lines { + "# @package o" 1 + "#@package o" 1 + "bla" 0 + "# @object o" 1 + "# 1 2 3" 1 + "#" 1 + "# " 1 + " # " 1 + "\t#\t \t" 1 + "# 345" 1 + "# @tag1 part1" 1 + "bla; # no comment" 0 + "" 0 + "\t\t" 0 + "### # # # # @object o # ####" 1 + "# # # # # 345" 1 + "# # # @tag1 part1" 1 + "bla; # # # # # no comment" 0 + " " 0 + + } + + foreach {::line ::result} $lines { + ? {foreach {is_comment text} [doc analyze_line $::line] break; set is_comment} $::result "doc analyze_line '$::line'" + } + + set script { + # @package o + # 1 2 3 + bla + bla + # @object o + # 1 2 3 + # + # 345 + # @tag1 part1 + # @tag2 part2 + bla; # no comment + bla + bla + bla + + + ### # # # # @object o # #### + # 1 2 3 + # + # # # # # 345 + # # # @tag1 part1 + # @tag2 part2 + bla; # # # # # no comment + } + + set blocks {1 {{ @package o} { 1 2 3}} 5 {{ @object o} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}} 17 {{ @object o # ####} { 1 2 3} {} { 345} { @tag1 part1} { @tag2 part2}}} + + ? [list ::lcompare [doc comment_blocks $script] $blocks] 1 +} + +Test case parsing { + # + # TODO: Add tests for doc-parsing state machine. + # + set block { + {@command ::cc} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? COMPLETED] 1 + + set block { + {} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? COMPLETED] 0 + ? [list $cbp status ? STYLEVIOLATION] 1 + + # + # For now, a valid comment block must start with a non-space line + # (i.e., a tag or text line, depending on the section: context + # vs. description) + # + + set block { + {} + {@command ::cc} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + set block { + {command ::cc} + {} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + set block { + {@command ::cc} + {some description} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + set block { + {@command ::cc} + {} + {} + {} + {@see ::o} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 0 + ? [list $cbp status ? COMPLETED] 1 + + set block { + {@command ::cc} + {} + {some description} + {some description2} + {} + {} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 0 + + # Note: We do allow description blocks with intermediate space + # lines, for now. + set block { + {@command ::cc} + {} + {some description} + {some description2} + {} + {an erroreneous description line, for now} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 0 + + # + # TODO: Do not enforce space line between the context and immediate + # part block (when description is skipped)? + # + # OR: For absolutely qualifying parts (e.g., outside of an initcmd block), + # do we need sequences of _two_ (or more) tag lines, e.g. + # + # -- + # @object Foo + # @param attr1 + # -- + # + # THEN, we can only discriminate between the context and an + # immediate part section by requiring a space line! + # + # Alternatively, we can use the @see like syntax for qualifying: + # @param ::Foo#attr1 (I have a preference for this option). + set block { + {@command ::cc} + {@see someOtherEntity} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + + # + # TODO: Disallow space lines between parts? Check back with Javadoc spec. + # + set block { + {@command ::cc} + {} + {@see SomeOtherEntity} + {add a line of description} + {} + {} + {@see SomeOtherEntity2} + {} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + # + # TODO: Should we enforce a mandatory space line between description and part block? + # + set block { + {@command ::cc} + {} + {add a line of description} + {a second line of description} + {a third line of description} + {@see entity3} + {@see SomeOtherEntity2} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + set block { + {@command ::cc} + {} + {add a line of description} + {a second line of description} + {a third line of description} + {} + {@see SomeOtherEntity2} + {} + {} + {an erroreneous description line, for now} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + set block { + {@command ::cc} + {} + {add a line of description} + {a second line of description} + {} + {a third line of description} + {} + {@see SomeOtherEntity2} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 0 + + set block { + {@object ::cc} + {} + {add a line of description} + {a second line of description} + {} + {@see SomeOtherEntity2} + {@xyz SomeOtherEntity2} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? INVALIDTAG] 1 + + set block { + {@class ::cc} + {} + {add a line of description} + {a second line of description} + {} + {@see SomeOtherEntity2} + {@xyz SomeOtherEntity2} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? INVALIDTAG] 1 + + # + # testing the doc object construction + # + set block { + {@object ::o} + {} + {some more text} + {and another line for the description} + {} + {@author stefan.sobernig@wu.ac.at} + {@author gustaf.neumann@wu-wien.ac.at} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? COMPLETED] 1 + set entity [$cbp current_entity] + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@object] 1 + ? [list $entity @author] "stefan.sobernig@wu.ac.at gustaf.neumann@wu-wien.ac.at"; + ? [list $entity as_text] "some more text and another line for the description"; + + set block { + {@command ::c} + {} + {some text on the command} + {} + {@see ::o} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? COMPLETED] 1 + set entity [$cbp current_entity] + + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@command] 1 + ? [list $entity as_text] "some text on the command"; + ? [list $entity @see] "::o"; + + set block { + {@class ::C} + {} + {some text on the class entity} + {} + {@class-attribute attr1 Here! we check whether we can get a valid description block} + {for text spanning multiple lines} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? COMPLETED] 1 + set entity [$cbp current_entity] + + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@class] 1 + ? [list $entity as_text] "some text on the class entity"; + ? [list llength [$entity @attribute]] 1 + ? [list [$entity @attribute] info has type ::nx::doc::@param] 1 + ? [list [$entity @attribute] as_text] "Here! we check whether we can get a valid description block for text spanning multiple lines" + + # + # basic test for in-situ documentation (initcmd block) + # + # + set script { + Class create Foo { + # The class Foo defines the behaviour for all Foo objects + # + # @author gustaf.neumann@wu-wien.ac.at + # @author ssoberni@wu.ac.at + + # @.attribute attr1 + # + # This attribute 1 is wonderful + # + # @see ::nx::Attribute + # @see ::nx::MetaSlot + :attribute attr1 + :attribute attr2 + :attribute attr3 + + # @.method foo + # + # This describes the foo method + # + # @parameter a Provides a first value + # @parameter b Provides a second value + :method foo {a b} {;} + } + } + + eval $script + doc process ::Foo + set entity [@class id ::Foo] + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@class] 1 + ? [list $entity as_text] "The class Foo defines the behaviour for all Foo objects"; + ? [list $entity @author] "gustaf.neumann@wu-wien.ac.at ssoberni@wu.ac.at" + # TODO: Fix the [@param id] programming scheme to allow (a) for + # entities to be passed and the (b) documented structures + set entity [@attribute id [@class id ::Foo] class attr1] + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity @see] "::nx::Attribute ::nx::MetaSlot"; + + set entity [@method id ::Foo class foo] + ? [list [@class id ::Foo] @method] $entity + ? [list ::nsf::is object $entity] 1 + ? [list $entity info has type ::nx::doc::@method] 1 + ? [list $entity as_text] "This describes the foo method"; + + foreach p [$entity @parameter] expected { + "Provides a first value" + "Provides a second value" + } { + ? [list expr [list [$p as_text] eq $expected]] 1; + } + + # TODO: how to realise scanning and parsing for mixed ex- and + # in-situ documentation? That is, how to differentiate between + # absolutely and relatively qualified comment blocks in line-based + # scanning phase (or later)? + + set script { + namespace import -force ::nx::* + # @class ::Bar + # + # The class Bar defines the behaviour for all Bar objects + # + # @author gustaf.neumann@wu-wien.ac.at + # @author ssoberni@wu.ac.at + + # @class.attribute {::Bar attr1} + # + # This attribute 1 is wonderful + # + # @see ::nx::Attribute + # @see ::nx::MetaSlot + + # @class.class-method {::Bar foo} + # + # + # This describes the foo method + # + # @parameter a Provides a first value + # @parameter b Provides a second value + + # @class.class-object-method {::Bar foo} + # + # This describes the per-object foo method + # + # @parameter a Provides a first value + # @parameter b Provides a second value + + namespace eval ::ns1 { + ::nx::Object create ooo + } + Class create Bar { + + :attribute attr1 + :attribute attr2 + :attribute attr3 + + # @.method foo + # + # This describes the foo method in the initcmd + # + # @parameter a Provides a first value + # @parameter b Provides a second value + + :method foo {a b} { + # This describes the foo method in the method body + # + # @parameter a Provides a first value (refined) + + } + + :class-object method foo {a b c} { + # This describes the per-object foo method in the method body + # + # @parameter b Provides a second value (refined) + # @parameter c Provides a third value (first time) + + } + + } + } + + set i [doc process $script] + + set entity [@class id ::Bar] + ? [list $i eval [list ::nsf::is object $entity]] 1 + ? [list $i eval [list $entity info has type ::nx::doc::@class]] 1 + ? [list $i eval [list $entity as_text]] "The class Bar defines the behaviour for all Bar objects"; + ? [list $i eval [list $entity @author]] "gustaf.neumann@wu-wien.ac.at ssoberni@wu.ac.at" + + # TODO: Fix the [@param id] programming scheme to allow (a) for + # entities to be passed and the (b) documented structures + set entity [@attribute id [@class id ::Bar] class attr1] + ? [list $i eval [list ::nsf::is object $entity]] 1 + ? [list $i eval [list $entity info has type ::nx::doc::@attribute]] 1 + ? [list $i eval [list $entity @see]] "::nx::Attribute ::nx::MetaSlot"; + + set entity [@method id ::Bar class foo] + ? [list $i eval [list [@class id ::Bar] @method]] $entity + ? [list $i eval [list ::nsf::is object $entity]] 1 + ? [list $i eval [list $entity info has type ::nx::doc::@method]] 1 + ? [list $i eval [list $entity as_text]] "This describes the foo method in the method body"; + + foreach p [$i eval [list $entity @parameter]] expected { + "Provides a first value (refined)" + "Provides a second value" + } { + ? [list expr [list [$i eval [list $p as_text]] eq $expected]] 1; + } + + + set entity [@method id ::Bar class-object foo] + ? [list $i eval [list [@class id ::Bar] @class-object-method]] $entity + ? [list $i eval [list ::nsf::is object $entity]] 1 + ? [list $i eval [list $entity info has type ::nx::doc::@method]] 1 + ? [list $i eval [list $entity as_text]] "This describes the per-object foo method in the method body"; + + foreach p [$i eval [list $entity @parameter]] expected { + "Provides a first value" + "Provides a second value (refined)" + "Provides a third value (first time)" + } { + ? [list expr [list [$i eval [list $p as_text]] eq $expected]] 1; + } + + + interp delete $i + + + # + # Some tests on structured/navigatable tag notations + # + + # adding support for parsing levels + + # -- @class.object.object {::D o1 o2} + set block { + {@..object o2 We have a tag notation sensitive to the parsing level} + } + + set entity [[@ @class ::D] @object o1] + set cbp [CommentBlockParser process -parsing_level 1 -partof_entity $entity $block] + ? [list $cbp status ? LEVELMISMATCH] 1 + set cbp [CommentBlockParser process -parsing_level 2 -partof_entity $entity $block] + ? [list $cbp status ? COMPLETED] 1 + set entity [$cbp current_entity] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@object] 1 + ? [list $entity as_text] "We have a tag notation sensitive to the parsing level" + + set block { + {@..object {o2 o3} We still look for balanced specs} + } + + set entity [[@ @class ::D] @object o1] + set cbp [CommentBlockParser process -parsing_level 2 -partof_entity $entity $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + + # This fails because we do not allow uninitialised/non-existing + # entity objects (@object o) along the resolution path ... + set block { + {@class.object.attribute {::C o attr1} We have an invalid specification} + } + + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? INVALIDTAG] 1 +# ? [list $cbp message] "The tag 'object' is not supported for the entity type '@class'" + + set block { + {@class.method.attribute attr1 We have an imbalanced specification (the names are underspecified!)} + } + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + ? [list $cbp message] "Imbalanced tag line spec: 'class method attribute' vs. 'attr1'" + + # For now, we do not verify and use a fixed scope of permissive tag + # names. So, punctuation errors or typos are most probably reported + # as imbalanced specs. In the mid-term run, this should rather + # become an INVALIDTAG condition. + set block { + {@cla.ss.method.parameter {::C foo p1} We mistyped a tag fragment} + } + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? STYLEVIOLATION] 1 + ? [list $cbp message] "Imbalanced tag line spec: 'cla ss method parameter' vs. '::C foo p1'" + + set block { + {@cla,ss.method.parameter {::C foo p1} We mistyped a tag fragment} + } + set cbp [CommentBlockParser process $block] + ? [list $cbp status ? INVALIDTAG] 1 + ? [list $cbp message] "The entity type '@cla,ss' is not available." + + set script { + # @class ::C + # + # The global description of ::C + # + # @attribute attr1 Here we can only provide a description block for object parameters + + # @class.attribute {::C attr1} Here, we could also write '@class.class-attribute \{::C attr1\}', @attribute is a mere forwarder! In the context section, only one-liners are allowed! + + # @class.object.attribute {::C foo p1} A short description is ... + # + # .. is overruled by a long one ... + + # If addressing to a nested object, one strategy would be to use + # @object and provide the object identifier (which reflects the + # nesting, e.g. ::C::foo). However, we cannot distinguish between + # namespace qualifiers denoting an object, class or owning + # namespace! + # + # ISSUE: If specifying an axis ".object", we would have to define + # a part attribute @object on @class and @object. However, @object + # would be ambiguous now: It could be called in a freestanding + # (absolute) manner AND in a contextualised manner (in an initcmd + # script). In the latter case, it would fail because we would have + # to provide a FQ'ed name (which defeats the purpose of a nested = + # contextualised notation). + # + # SO: for now, we introduce a part attribute child-object (and + # child-class?) to discrimate between the two situations ... + # + # TODO: How to register this so created @object entity as nested + # object with the doc entity represented the parent object? + + Class create C { + # This is the initcmd-level description of ::C which overwrites the + # global description (see above) + + # @.attribute attr1 + # + # This is equivalent to writing "@class-attribute attr1" + :attribute attr1 { + # This description does not apply to the object parameter + # "attr1" owned by the ::C class, rather it is a description + # of the attribute slot object! How should we deal with this + # situation? Should this level overwrite the top-level and + # initcmd-level descriptions? + } + + # @.class-object-attribute attr2 Carries a short desc only + :class-object attribute attr2 + + # @.method foo + # + # @parameter p1 + set fooHandle [:method foo {p1} { + # Here goes some method-body-level description + # + # @parameter p1 The most specific level! + return [current method]-$p1-[current] + }] + + # @.class-object-method.parameter {bar p1} + # + # This extended form allows to describe a method parameter with all + # its structural features! + set barHandle [:class-object method bar {p1} { + return [current method]-$p1-[current] + }] + + # @.object foo 'foo' needs to be defined before referencing any of its parts! + + # @.object.attribute {foo p1} + # + # The first element in the name list is resolved into a fully + # qualified (absolute) entity, based on the object owning the + # initcmd! + Object create [current]::foo { + # Adding a line for the first time (not processed in the initcmd phase!) + + # @..attribute p1 + # + # This is equivalent to stating "@class-object-attribute p1" + :attribute p1 + } + + # @.class Foo X + # + # By providing a fully-qualified identifier ("::Foo") you leave the + # context of the initcmd-owning object, i.e. you would NOT refer to + # a nested class object named "Foo" anymore! + + # @.class.attribute {Foo p1} + # + # This is equivalent to stating "@child-class.class-attribute {Foo p1}" + + # @.class.class-object-attribute {Foo p2} Y + Class create [current]::Foo { + + # @..attribute p1 + # + # + # This is equivalent to stating "@class-attribute p1"; or + # '@class.object.attribute {::C Foo p1}' from the top-level. + :attribute p1 + + # @..class-object-attribute p2 + :class-object attribute p2 + } + + + # @.class-object-method.sub-method {sub foo} + # + # ISSUE: Should submethods be navigatable through "method" (i.e., + # "@method.method.method ...") or "submethod" (i.e., + # "@method.submethod.submethod ...")? ISSUE: Should it be sub* with + # "-" (to correspond to "@class-object-method", "@class-method")? Also, we + # could allow both (@sub-method is the attribute name, @method is a + # forwarder in the context of an owning @method object!) + # + # @parameter p1 Some words on p1 + :class-object alias "sub foo" $fooHandle + + # @.method sub + # + # The desc of the ensemble object 'sub' + # + # @sub-method bar Only description available here ... + + # ISSUE: Should the helper object "sub" be documentable in its own + # right? This would be feasible with the dotted notation from + # within and outside the initcmd script block, e.g. "@object sub" or + # "@class.object {::C sub}" + # + # ISSUE: Is it correct to say the sub appears as per-object method + # and so do its submethods? Or is it misleading to document it that + # way? Having an "@class-object-submethod" would not make much sense to + # me?! + :alias "sub bar" $barHandle + + # @.class-object-method sub A brief desc + + # @.class-object-method {"sub foo2"} + # + # could allow both (@sub-method is the attribute name, @method is a + # forwarder in the context of an owning @method object!) + # + # @parameter p1 Some words on p1 + # @see anotherentity + # @author ss@thinkersfoot.net + :class-object alias "sub foo2" $fooHandle + } + } + + # + # 1) process the top-level comments (PARSING LEVEL 0) + # + + doc analyze -noeval true $script + + # --testing-- "@class ::C" + set entity [@class id ::C] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@class] 1 + ? [list $entity as_text] "The global description of ::C"; + # --testing-- "@class.attribute {::C attr1}" + set entity [@attribute id $entity class attr1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity as_text] "Here, we could also write '@class.class-attribute {::C attr1}', @attribute is a mere forwarder! In the context section, only one-liners are allowed!" + + # --testing-- "@class.object.attribute {::C foo p1} A short description is ..." + # set entity [@attribute id $entity class attr1] + # set entity [@object id -partof_name ::C -scope child foo] + # ? [list ::nsf::isobject $entity] 1 + # ? [list $entity info has type ::nx::doc::@object] 1 + # ? [list $entity as_text] "" + # set entity [@attribute id $entity object p1] + # ? [list ::nsf::isobject $entity] 1 + # ? [list $entity info has type ::nx::doc::@attribute] 1 + # ? [list $entity as_text] ".. is overruled by a long one ..." + + set entity [@object id ::C::foo] + ? [list ::nsf::isobject $entity] 0 + set entity [@attribute id $entity class-object p1] + ? [list ::nsf::isobject $entity] 0 + # ? [list $entity info has type ::nx::doc::@attribute] 1 + # ? [list $entity as_text] ".. is overruled by a long one ..." + + # --testing-- @class-object-attribute attr2 (its non-existance) + set entity [@attribute id [@class id ::C] class-object attr2] + ? [list ::nsf::isobject $entity] 0 + # --testing-- @child-class Foo (its non-existance) + set entity [@class id ::C::Foo] + ? [list ::nsf::isobject $entity] 0 + # --testing -- @method foo (its non-existance) + set entity [@method id ::C class foo] + ? [list ::nsf::isobject $entity] 0 + # --testing-- @class-object-method.parameter {bar p1} (its non-existance) + set entity [@parameter id [@method id ::C class-object bar] "" p1] + ? [list ::nsf::isobject $entity] 0 + # --testing-- @child-object.attribute {foo p1} (its non-existance) + set cl [@class id ::C::Foo] + ? [list ::nsf::isobject $entity] 0 + set entity [@attribute id $cl class p1] + ? [list ::nsf::isobject $entity] 0 + set entity [@attribute id $cl class-object p2] + ? [list ::nsf::isobject $entity] 0 + + # + # 2) process the initcmd comments (PARSING LEVEL 1) + # + + eval $script + + doc analyze_initcmd @class ::C [::C eval {set :__initcmd}] + + # a) existing, but modified ... + + set entity [@class id ::C] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@class] 1 + ? [list $entity as_text] "This is the initcmd-level description of ::C which overwrites the global description (see above)" + + set entity [@attribute id $entity class attr1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity as_text] {This is equivalent to writing "@class-attribute attr1"} + + + set entity [@object id ::C::foo] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@object] 1 + ? [list $entity as_text] "'foo' needs to be defined before referencing any of its parts!"; # still empty! + set entity [@attribute id $entity class-object p1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity as_text] "The first element in the name list is resolved into a fully qualified (absolute) entity, based on the object owning the initcmd!" + + # b) newly added ... + + # --testing-- @class-object-attribute attr2 + set entity [@attribute id [@class id ::C] class-object attr2] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity as_text] "Carries a short desc only"; + + # --testing-- @child-class Foo + # TODO: provide a check against fully-qualified names in part specifications + set entity [@class id ::C::Foo] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@class] 1 + ? [list $entity as_text] {By providing a fully-qualified identifier ("::Foo") you leave the context of the initcmd-owning object, i.e. you would NOT refer to a nested class object named "Foo" anymore!} + + set entity [@attribute id [@class id ::C] class p1] + ? [list ::nsf::isobject $entity] 0; # should be 0 at this stage! + + # --testing -- @method foo + set entity [@method id ::C class foo] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "" + # --testing-- @class-object-method.parameter {bar p1} (its non-existance) It + # still cannot exist as a documented entity, as the class-object method + # has not been initialised before! + set entity [@parameter id [@method id ::C class-object bar] "" p1] + ? [list ::nsf::isobject $entity] 0 + # --testing-- @child-class.attribute {foo p1} (its non-existance) + # --testing-- @child-class.object-attribute {foo p2} (its non-existance) + set cl [@class id ::C::Foo] + ? [list ::nsf::isobject $cl] 1 + set entity [@attribute id $cl class p1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] {This is equivalent to stating "@child-class.class-attribute {Foo p1}"} + set entity [@attribute id $cl class-object p2] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "Y" + + set entity [@method id ::C class sub] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "The desc of the ensemble object 'sub'" + + set entity [@method id ::C class sub::bar] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "Only description available here ..." + + set entity [@method id ::C class-object sub] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "A brief desc" + + set entity [@method id ::C class-object sub::foo2] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@method] 1 + ? [list $entity as_text] "could allow both (@sub-method is the attribute name, @method is a forwarder in the context of an owning @method object!)" + ? [list $entity @see] "anotherentity" + # TODO: @author not supported for @method (fine so?) + # ? [list $entity @author] "ss@thinkersfoot" + set entity [@parameter id $entity "" p1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "Some words on p1" + + # + # 3a) process the attribute initcmds and method bodies (PARSING LEVEL 2)! + # + + doc process=@class [@class id ::C] + + # methods ... + + set entity [@method id ::C class foo] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "Here goes some method-body-level description" + set entity [@parameter id [@method id ::C class foo] "" p1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "The most specific level!" + + # attributes ... + + # attr1 + set entity [@attribute id [@class id ::C] class attr1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity as_text] {This description does not apply to the object parameter "attr1" owned by the ::C class, rather it is a description of the attribute slot object! How should we deal with this situation? Should this level overwrite the top-level and initcmd-level descriptions?} + + # + # 3b) nested objects/ classes (PARSING LEVEL 2)! + # + + doc analyze_initcmd -parsing_level 2 @object ::C::foo [::C::foo eval {set :__initcmd}] + doc process=@object [@object id ::C::foo] + + set entity [@object id ::C::foo] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@object] 1 + ? [list $entity as_text] "Adding a line for the first time (not processed in the initcmd phase!)"; # still empty! + set entity [@attribute id $entity class-object p1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity info has type ::nx::doc::@attribute] 1 + ? [list $entity as_text] {This is equivalent to stating "@class-object-attribute p1"} + + doc analyze_initcmd -parsing_level 2 @class ::C::Foo [::C::Foo eval {set :__initcmd}] + doc process=@class [@class id ::C::Foo] + + set cl [@class id ::C::Foo] + ? [list ::nsf::isobject $cl] 1 + set entity [@attribute id $cl class p1] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] {This is equivalent to stating "@class-attribute p1"; or '@class.object.attribute {::C Foo p1}' from the top-level.} + set entity [@attribute id $cl class-object p2] + ? [list ::nsf::isobject $entity] 1 + ? [list $entity as_text] "" + + puts stderr ================================================= + # + # self documentation + # + # if {[catch {set i [doc process nx::doc]} msg]} { + # puts stderr ERRORINFO=$::errorInfo + # if {[Exception behind? $msg]} { + # puts stderr [$msg info class]->[$msg message] + # } else { + # error $msg + # } + # } + # ? [list $i eval [list ::nsf::is object [@package id nx::doc]]] 1 + # puts stderr [$i eval [list [@package id nx::doc] text]] + # puts stderr [$i eval [list [@package id nx::doc] @require]] + # set path [file join /tmp nextdoc] + # if {[file exists $path]} { + # file delete -force $path + # } + # $i eval [list ::nx::doc::make doc \ + # -renderer ::nx::doc::TemplateData \ + # -outdir /tmp \ + # -project {name nextdoc url http://www.next-scripting.org/ version 0.1d}] + # interp delete $i + + # + # core documentation + # + foreach path [list [file join [::nsf::tmpdir] NextScriptingFramework] \ + [file join [::nsf::tmpdir] NextScriptingLanguage]] { + if {[file exists $path]} { + file delete -force $path + } + } + + set i [interp create] + $i eval { + package req nx::doc + namespace import ::nx::* + namespace import ::nx::doc::* + + # 1) NSF documentation project + set project [::nx::doc::@project new \ + -name NextScriptingFramework \ + -url http://www.next-scripting.org/ \ + -version 1.0.0a \ + -@namespace "::nsf"] + + doc process -noeval true generic/nsf.tcl + + ::nx::doc::make doc \ + -renderer ::nx::doc::NxDocRenderer \ + -project $project \ + -outdir [::nsf::tmpdir] + + #puts stderr NSF=[info commands ::nx::doc::entities::command::nsf::*] + + puts stderr TIMING=[time { + set project [::nx::doc::@project new \ + -name NextScriptingLanguage \ + -url http://www.next-scripting.org/ \ + -version 1.0.0a \ + -@namespace "::nx"] + # ISSUE: If calling '-namespace "::nx"' instead of '-@namespace + # "::nx"', we get an irritating failure. VERIFY! + doc process -noeval true library/nx/nx.tcl + ::nx::doc::make doc \ + -renderer ::nx::doc::NxDocRenderer \ + -project $project \ + -outdir [::nsf::tmpdir] + } 1] + } + + interp delete $i + + set _ { + # 2) XOTcl2 documentation project + doc process -noeval true library/xotcl/xotcl.tcl + ::nx::doc::make doc \ + -renderer ::nx::doc::NxDocTemplateData \ + -outdir [::nsf::tmpdir] \ + -project {name XOTcl2 url http://www.xotcl.org/ version 2.0.0a} + + # 3) NSL documentation project + doc process -noeval true library/nx/nx.tcl + ::nx::doc::make doc \ + -renderer ::nx::doc::NxDocTemplateData \ + -outdir [::nsf::tmpdir] \ + -project {name NextScriptingLanguage url http://www.next-scripting.org/ version 1.0.0a} + + # 4) Next Scripting Libraries + # doc process -noeval true ... + # ::nx::doc::make doc \ + # -renderer ::nx::doc::NxDocTemplateData \ + # -outdir [::nsf::tmpdir] \ + # -project {name NextScriptingLibraries url http://www.next-scripting.org/ version 1.0.0a} + } + +} + + +# # # # # # # # # # # # # # # # # # # # +# # # # # # # # # # # # # # # # # # # # +# # # # # # # # # # # # # # # # # # # # + +# 1) Test case scoping rules -> in Object->eval() + +Test case issues? { + + # TODO: where to locate the @ comments (in predefined.xotcl, in + # gentclAPI.decls)? how to deal with ::nsf::* vs. ::nx::* + + # TODO: which values are returned from Object->configure() and + # passed to init()? how to document residualargs()? + + # TODO: Object->cleanup() said: "Resets an object or class into an + # initial state, as after construction." If by construction it means + # after create(), then cleanup() is missing a configure() call to + # set defaults, etc! + # ?? cleanup does not set defaults; depending on "softrecreate", it + # deletes instances, childobjects, procs, instprocs, ... + + # TODO: what is Object->__next() for? + + # See the following script: + # + +# Object instproc defaultmethod {} {puts "[self proc]"; return [self]} +# Class A +# A instproc defaultmethod {} {puts "[self proc]"; [::xotcl::my info parent] __next} +# Class D -instproc t {} {puts "my stuff"} +# D create d1 +# puts [d1 t] +# ### we create a subobject named t, which shadows effectively D->t +# A create d1::t +# puts === +# # when we call "d1 t", we effectively call "d1::t", which calls "default method". +# # the defaultmethod should do a next on object d1. +# puts [d1 t] +# puts ===EXIT + + # but seems - at least in this usecase broken. Deactivated + # in source for now. + + # TODO: why is XOTclOUplevelMethodStub/XOTclOUplevelMethod defined + # with "args" while it logically uses the stipulated parameter + # signature (level ...). is this because of the first pos, optional + # parameter? ... same goes for upvar() ... + + # the logic is a tribute to the argument logic in Tcl, which complex. + # uplevel ?level? arg ?arg ...? + # It is a combination between an optional first argument and + # and an args logic. + # + # Most likely, it could be partly solved with a logic for optional + # first arguments (if the number of actual arguments is + # higher than the minimal number of arguments, one could fill optional + # parameter up..... but this calculation requires as well the interactions + # with nonpos arguments, which might be values for positional arguments + # as well.... not, sure, it is worth to invest much time here. + + # TODO: how is upvar affected by the ":"-prefixing? -> AVOID_RESOLVERS ... + + # this is a tcl question, maybe version dependent. + + + + # TODO: the objectsystems subcommand of ::nsf::configure does + # not really fit in there because it does not allow for configuring + # anything. it is a mere introspection-only command. relocate (can + # we extend standard [info] somehow, i.e., [info objectsystems] + + # what means "configuring anything"? + # maybe you are refering to "configure objectsystems" which is parked there. + # there would be an option to change the internally called methods via + # configure as well, but i think, one is asking for troubles by allowing + # this. + # extending info is possible via the shadowcommands, but the tct + # does not like it. + # + # ad configure: we could fold as well methodproperty and + # objectproperty into configure since these allow as well setting + # and querying.... + # + # configure method METHODHANDLE public + # configure object OBJECT metaclass + # + # but there, the object property is just for quering. + # Another option is define and "info" + # + # ::nsf::info object OBJECT metaclass + # ::nsf::info objectsystems + # + # but if we would fold these into tcl-info, conflicts with + # tcl will arise. + + # ISSUE: Object->info->parameter() still needed to retrieve + # objectparameters? + + # TODO: decide how to deal with @package and @project names (don't + # need namespace delimiters!) + +} + +# if {$log} { +# ::nx::doc::CommentState mixin delete ::nx::doc::CommentState::Log +# ::nx::doc::CommentLine mixin delete ::nx::doc::CommentLine::Log +# ::nx::doc::CommentSection mixin delete ::nx::doc::CommentSection::Log +# } Index: tests/forward.test =================================================================== diff -u --- tests/forward.test (revision 0) +++ tests/forward.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,390 @@ +# -*- Tcl -*- +package require nx; namespace import ::nx::* +package require nx::test + +########################################### +# trivial object delegation +########################################### +Test case delegation { + Object create dog + Object create tail { + :public method wag args { return $args } + } + dog public forward wag tail %proc + + ? {dog wag 100} 100 +} + + +########################################### +# evaluating in scope +########################################### +Test case inscope { + Class create X { + :attribute {x 1} + :public forward Incr -objscope incr + } + + X create x1 -x 100 + x1 Incr x + x1 Incr x + x1 Incr x + ? {x1 x} 103 +} + +########################################### +# adding +########################################### +Test case adding { + Object create obj { + :public forward addOne expr 1 + + } + + ? {obj addOne 5} 6 +} + +########################################### +# more arguments +########################################### +Test case multiple-args { + Object create target { + :public method foo args {return $args} + } + Object create obj { + :public forward foo target %proc %self a1 a2 + } + + ? {obj foo x1 x2} [list ::obj a1 a2 x1 x2] + + obj public forward foo target %proc %self %%self %%p + ? {obj foo x1 x2} [list ::obj %self %p x1 x2] +} + +########################################### +# mixin example +########################################### +Test case mixin-via-forward { + Object create mixin { + :method unknown {m args} {return [concat [current] $m $args]} + } + + Object create obj { + :public forward Mixin mixin %1 %self + } + + ? {obj Mixin add M1} [list ::mixin add ::obj M1] + ? {catch {obj Mixin}} 1 + + obj public forward Mixin mixin "%1 {Getter Setter}" %self + ? {obj Mixin add M1} [list ::mixin add ::obj M1] + ? {obj Mixin M1} [list ::mixin Setter ::obj M1] + ? {obj Mixin} [list ::mixin Getter ::obj] +} + + +########################################### +# sketching extensibe info +########################################### +Test case info-via-forward { + Object create Info { + :public method @mixin {o} { + $o info mixin + } + :public method @class {o} { ;# without prefix, doing here a [Info class] wod be wrong + $o info class + } + :public method @help {o} { ;# define a new subcommand for info + foreach c [:info methods] {lappend result [string range $c 1 end]} + return $result + } + } + Object public forward Info -methodprefix @ Info %1 %self + + Class create X { + :create x1 + } + ? {x1 Info class} ::X + ? {x1 Info help} [list help mixin class] +} + +########################################### +# variations of placement of options +########################################### +Test case incr { + Object create obj { + set :x 1 + :public forward i1 -objscope incr x + } + + ? {obj i1} 2 +} + +########################################### +# introspeciton options +########################################### +Test case introspection { + Class create C { + :public forward Info -methodprefix @ Info %1 %self + } + + ? {C info methods -methodtype forwarder} Info + C public forward XXXo x + ? {lsort [C info methods -methodtype forwarder]} [list Info XXXo] + + ? {C info methods -methodtype forwarder X*} [list XXXo] + ? {lsort [C info methods -methodtype forwarder *o]} [list Info XXXo] + + # delete the forwarder + C method XXXo {} {} + ? {C info methods -methodtype forwarder} [list Info] + + # get the definition of a instforwarder + ? {C info method definition Info} [list ::C public forward Info -methodprefix @ Info %1 %self] + + # check introspection for objects + Object create obj { + :public forward i1 -objscope incr x + :public forward Mixin mixin %1 %self + :public forward foo target %proc %self %%self %%p + :public forward addOne expr 1 + + } + + ? {lsort [obj info methods -methodtype forwarder]} "Mixin addOne foo i1" + ? {obj info method definition Mixin} "::obj public forward Mixin mixin %1 %self" + ? {obj info method definition addOne} "::obj public forward addOne expr 1 +" + ? {obj info method definition foo} "::obj public forward foo target %proc %self %%self %%p" + ? {obj info method definition i1} "::obj public forward i1 -objscope ::incr x" +} + +########################################### +# test serializer +########################################### +package require nx::serializer +Test case serializer { + Object create obj { + :method test {} {puts "i am [current method]"} + } + set ::a [Serializer deepSerialize obj] + #puts <<$::a>> + eval $::a + ? {set ::a} [Serializer deepSerialize obj] +} + +########################################### +# test optional target cmd +########################################### +Test case optional-target { + Object create obj { + set :x 2 + :public forward append -objscope + } + ? {obj append x y z} 2yz + + Object create n; Object create n::x {:public method current {} {current}} + Object create o + o public forward ::n::x + ? {o x current} ::n::x +} + +########################################### +# arg including instvar +########################################### +Test case percent-cmd { + Object create obj { + set :x 10 + :public forward x* expr {%:eval {set :x}} * + } + ? {obj x* 10} "100" +} + +########################################### +# positional arguments +########################################### +Test case positioning-args { + Object create obj + obj public forward @end-13 list {%@end 13} + ? {obj @end-13 1 2 3 } [list 1 2 3 13] + + obj public forward @-1-13 list {%@-1 13} + ? {obj @-1-13 1 2 3 } [list 1 2 13 3] + + obj public forward @1-13 list {%@1 13} + ? {obj @1-13 1 2 3 } [list 13 1 2 3] + ? {obj @1-13} [list 13] + + obj public forward @2-13 list {%@2 13} + ? {obj @2-13 1 2 3 } [list 1 13 2 3] + + obj public forward @list 10 {%@0 list} {%@end 99} + ? {obj @list} [list 10 99] + ? {obj @list a b c} [list 10 a b c 99] + + obj public forward @list {%@end 99} {%@0 list} 10 + ? {obj @list} [list 10 99] + ? {obj @list a b c} [list 10 a b c 99] + + obj public forward @list {%@2 2} {%@1 1} {%@0 list} + ? {obj @list} [list 1 2] + ? {obj @list a b c} [list 1 2 a b c] + + obj public forward @list x y z {%@0 list} {%@1 1} {%@2 2} + ? {obj @list} [list 1 2 x y z] + ? {obj @list a b c} [list 1 2 x y z a b c] + + obj public forward @list x y z {%@2 2} {%@1 1} {%@0 list} + ? {obj @list} [list x 1 y 2 z] + ? {obj @list a b c} [list x 1 y 2 z a b c] + + # adding some test cases which cover the interactions + # between %@POS and %1 substitutions + # + + obj public forward @end-13 list {%@end 13} %1 %self + ? {obj @end-13 1 2 3 } [list 1 ::obj 2 3 13] + + obj public forward @end-13 list %1 {%@end 13} %self + ? {obj @end-13 1 2 3 } [list 1 ::obj 2 3 13] + + obj public forward @end-13 list {%@end 13} %1 %1 %1 %self + ? {obj @end-13 1 2 3 } [list 1 1 1 ::obj 2 3 13] + + obj public forward @end-13 list {%@-1 13} %1 %self + ? {obj @end-13 1 2 3 } [list 1 ::obj 2 13 3] + + obj public forward @end-13 list {%@1 13} %1 %self + ? {obj @end-13 1 2 3 } [list 13 1 ::obj 2 3] +} + +############################################### +# substitution depending on number of arguments +############################################### +Test case num-args { + Object create obj { + :public forward f %self [list %argclindex [list a b c]] + :method a args {return [list [current method] $args]} + :method b args {return [list [current method] $args]} + :method c args {return [list [current method] $args]} + } + ? {obj f} [list a {}] + ? {obj f 1 } [list b 1] + ? {obj f 1 2} [list c {1 2}] + ? {catch {obj f 1 2 3}} 1 +} + +############################################### +# option earlybinding +############################################### +Test case earlybinding { + Object create obj { + :public forward s -earlybinding ::set ::X + } + ? {obj s 100} 100 + ? {obj s} 100 + + Object public method f args { next } + + Class create NS + Class create NS::Main { + :public class-object method m1 {} { :m2 } + :public class-object method m2 {} { + ? {namespace eval :: {Object create toplevelObj1}} ::toplevelObj1 + + ? [list set _ [namespace current]] ::NS + ? [list set _ [NS create m1]] ::NS::m1 + NS filter f + ? [list set _ [NS create m2]] ::NS::m2 + NS filter "" + + namespace eval ::test { + ? [list set _ [NS create m3]] ::test::m3 + NS filter f + ? [list set _ [NS create m4]] ::test::m4 + NS filter "" + } + + namespace eval test { + ? [list set _ [NS create m5]] ::NS::test::m5 + NS filter f + ? [list set _ [NS create m6]] ::NS::test::m6 + NS filter "" + } + } + + :public method i1 {} { :i2 } + :public method i2 {} { + ? {namespace eval :: {Object create toplevelObj2}} ::toplevelObj2 + + ? [list set _ [namespace current]] ::NS + ? [list set _ [NS create i1]] ::NS::i1 + NS filter f + ? [list set _ [NS create i2]] ::NS::i2 + NS filter "" + + namespace eval ::test { + ? [list set _ [NS create i3]] ::test::i3 + NS filter f + ? [list set _ [NS create i4]] ::test::i4 + NS filter "" + } + + namespace eval test { + ? [list set _ [NS create i5]] ::NS::test::i5 + NS filter f + ? [list set _ [NS create i6]] ::NS::test::i6 + NS filter "" + } + + } + } + + #puts ==== + NS::Main m1 + NS::Main create m + m i1 + + #puts ==== + ? [list set _ [NS create n1]] ::n1 + NS filter f + ? [list set _ [NS create n2]] ::n2 + NS filter "" + + #puts ==== + namespace eval test { + ? [list set _ [NS create n1]] ::test::n1 + ? [list set _ [NS create n3]] ::test::n3 + NS filter f + ? [list set _ [NS create n4]] ::test::n4 + NS filter "" + } +} +########################################### +# forward to expr + callstack +########################################### +Test case callstack { + Object public forward expr -objscope + + Class create C { + :method xx {} {current} + :public class-object method t {o expr} { + return [$o expr $expr] + } + } + C create c1 + + ? {c1 expr {[current]}} ::c1 + ? {c1 expr {[current] eq "::c1"}} 1 + ? {c1 expr {[:xx]}} ::c1 + ? {c1 expr {[:info class]}} ::C + ? {c1 expr {[:info has type C]}} 1 + ? {c1 expr {[:info has type ::C]}} 1 + + ? {C t ::c1 {[current]}} ::c1 + ? {C t ::c1 {[current] eq "::c1"}} 1 + ? {C t ::c1 {[:xx]}} ::c1 + ? {C t ::c1 {[:info class]}} ::C + ? {C t ::c1 {[:info has type C]}} 1 + ? {C t ::c1 {[:info has type ::C]}} 1 + + Object method expr {} {} + +} \ No newline at end of file Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/forwardtest.tcl'. Fisheye: No comparison available. Pass `N' to diff? Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/info-method.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/info-method.test =================================================================== diff -u --- tests/info-method.test (revision 0) +++ tests/info-method.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,402 @@ +# -*- Tcl *-* +package req nx +::nx::configure defaultMethodCallProtection false +package require nx::test + +Test case base { + nx::Object create o { + :alias set ::set + } + + nx::Class create C { + :method m {x} {return proc-[self proc]} + :class-object method mpo {} {return instproc-[self proc]} + :method m-with-assertions {} {return proc-[self proc]} -precondition 1 -postcondition 2 + + :forward addOne expr 1 + + :class-object forward add1 expr 1 + + :class-object forward fpo ::o + + :setter s + :class-object setter spo + + :alias a ::set + :class-object alias apo ::puts + } + C create c1 + + ? {lsort [C info methods -callprotection all]} "a addOne m m-with-assertions s" + #? {lsort [C info methods]} "a addOne s" + foreach m [lsort [C info methods -callprotection all]] { + ? [subst -nocommands {lsort [c1 info lookup methods $m]}] $m + } + ? {C info method definition a} "::C public alias a ::set" + ? {c1 info lookup method a} "::nsf::classes::C::a" + ? {c1 info lookup method addOne} "::nsf::classes::C::addOne" + ? {c1 info lookup method m} "::nsf::classes::C::m" + ? {c1 info lookup method s} "::nsf::classes::C::s" + c1 method foo {} {puts foo} + ? {c1 info method definition foo} "::c1 public method foo {} {puts foo}" + ? {c1 info lookup method foo} "::c1::foo" + + ? {C info method handle m} "::nsf::classes::C::m" + ? {C class-object info method handle mpo} "::C::mpo" + + ? {C info method definition m} {::C public method m x {return proc-[self proc]}} + ? {C info method def m} {::C public method m x {return proc-[self proc]}} + ? {C class-object info method definition mpo} {::C public class-object method mpo {} {return instproc-[self proc]}} + ? {C info method definition m-with-assertions} \ + {::C public method m-with-assertions {} {return proc-[self proc]} -precondition 1 -postcondition 2} + ? {C info method parameter m} {x} + ? {nx::Class info method parameter method} \ + {name arguments body -precondition -postcondition} + ? {nx::Object info method parameter alias} \ + {methodName {-frame default} cmd} + # raises currently an error + ? {catch {C info method parameter a}} 1 + + ? {C info method definition addOne} "::C public forward addOne expr 1 +" + ? {C class-object info method definition add1} "::C public class-object forward add1 expr 1 +" + ? {C class-object info method definition fpo} "::C public class-object forward fpo ::o" + + ? {C info method definition s} "::C public setter s" + ? {C class-object info method definition spo} "::C public class-object setter spo" + + ? {C info method definition a} "::C public alias a ::set" + ? {C class-object info method definition apo} "::C public class-object alias apo ::puts" + + ? {::nx::Object info lookup methods -source application} "" + ? {::nx::Class info lookup methods -source application} "" + + set object_methods "alias attribute class configure contains copy destroy eval filter forward info method mixin move protected public require setter volatile vwait" + set class_methods "alias alloc attribute attributes class class-object configure contains copy create dealloc destroy eval filter forward info method mixin move new protected public require setter superclass volatile vwait" + + ? {lsort [::nx::Object info lookup methods -source baseclasses]} $class_methods + ? {lsort [::nx::Class info lookup methods -source baseclasses]} $class_methods + ? {lsort [::nx::Object info lookup methods -source all]} $class_methods + ? {lsort [::nx::Class info lookup methods -source all]} $class_methods + ? {lsort [::nx::Object info lookup methods]} $class_methods + ? {lsort [::nx::Class info lookup methods]} $class_methods + ? {lsort [C info lookup methods -source application]} "add1 apo fpo mpo spo" + ? {lsort [c1 info lookup methods -source application]} "a addOne foo m m-with-assertions s" + ? {lsort [C info lookup methods -source baseclasses]} $class_methods + ? {lsort [c1 info lookup methods -source baseclasses]} $object_methods + + ::nx::configure defaultMethodCallProtection true + # + # the subsequent tests assume defaultMethodCallProtection == true + # + ? {::nx::configure defaultMethodCallProtection} true + + ::nx::Class create MC -superclass ::nx::Class { + :protected method bar1 args {;} + :method bar2 args {;} + :public method foo args {;} + :public class-object method foo args {;} + } + + ? {lsort [MC info methods -methodtype scripted -callprotection public]} "foo" + ? {lsort [MC info methods -methodtype scripted -callprotection protected]} "bar1 bar2" + ? {lsort [MC info methods -methodtype scripted -callprotection all]} "bar1 bar2 foo" + + + ::nsf::methodproperty ::MC foo call-protected true + ::nsf::methodproperty ::MC bar2 call-protected false + + ? {lsort [MC info methods -methodtype scripted -callprotection public]} "bar2" + ? {lsort [MC info methods -methodtype scripted -callprotection protected]} "bar1 foo" + ? {lsort [MC info methods -methodtype scripted -callprotection all]} "bar1 bar2 foo" + ::nx::configure defaultMethodCallProtection false +} + +Test case subobj { + ::nx::Object create o { + ::nx::Object create [::nx::self]::sub { + :method foo {} {;} + } + :alias subal ::o::sub + } + ? {o info methods} "sub subal" + ? {o info method type sub} "object" + ? {o info method definition sub} "::nx::Object create ::o::sub" + ? {o info method type subal} "alias" +} + +Test case callable { + # define the same method for Object and Class + ::nx::Object method bar {} {return Object.bar} + ::nx::Class method bar {} {return Class.bar} + + ::nx::Object create o + ? {o info lookup method bar} "::nsf::classes::nx::Object::bar" + ? {o info lookup methods bar} bar + ? {o bar} Object.bar + + o mixin ::nx::Class + ? {o info lookup method bar} "::nsf::classes::nx::Class::bar" + ? {o info lookup methods bar} bar + ? {o info lookup methods superclass} "" + ? {o info lookup method superclass} "" + ? {o bar} Class.bar + + ? {o method foo {} {return o.foo}} "::o::foo" + ? {o alias is ::nsf::is} "::o::is" + ? {o setter x} "::o::x" + ? {lsort [o info methods]} "foo is x" + + ? {o attribute A} ::o::A + ? {o forward fwd ::set} ::o::fwd + ? {lsort [o info methods]} "A foo fwd is x" + + o method f args ::nx::next + ? {o info lookup methods superclass} "" + ? {o info lookup methods filter} "filter" + ? {o info lookup method filter} "::nsf::classes::nx::Object::filter" + ? {o filter f} "" + ? {o filter guard f { 1 == 1 }} "" + ? {o info filter guard f} " 1 == 1 " + ? {o filter guard f} " 1 == 1 " + o filter "" + + nx::Class create Foo + ? {Foo method f args ::nx::next} "::nsf::classes::Foo::f" + ? {Foo method f2 args ::nx::next} "::nsf::classes::Foo::f2" + ? {Foo filter {f f2}} "" + ? {Foo info filter methods} "f f2" + ? {Foo filter guard f {2 == 2}} "" + ? {Foo info filter guard f} "2 == 2" + ? {Foo info filter methods -guards f} "{f -guard {2 == 2}}" + ? {Foo info filter methods -guards f2} "f2" + ? {Foo info filter methods -guards} "{f -guard {2 == 2}} f2" + ? {Foo filter {}} "" + + ? {Foo class-object method f args ::nx::next} "::Foo::f" + ? {Foo class-object method f2 args ::nx::next} "::Foo::f2" + ? {Foo class-object filter {f f2}} "" + ? {Foo class-object info filter methods} "f f2" + ? {Foo class-object filter guard f {2 == 2}} "" + ? {Foo class-object info filter guard f} "2 == 2" + ? {Foo class-object info filter methods -guards f} "{f -guard {2 == 2}}" + ? {Foo class-object info filter methods -guards f2} "f2" + ? {Foo class-object info filter methods -guards} "{f -guard {2 == 2}} f2" + ? {Foo class-object filter {}} "" + Foo destroy + + nx::Class create Fly + o mixin add Fly + ? {o info mixin classes} "::Fly ::nx::Class" + ? {o mixin guard ::Fly {1}} "" + ? {o info mixin classes -guards} "{::Fly -guard 1} ::nx::Class" + ? {o info mixin classes -guards Fly} "{::Fly -guard 1}" + o mixin delete ::Fly + ? {o info mixin classes} "::nx::Class" + + nx::Class create Foo + Foo mixin add ::nx::Class + Foo mixin add Fly + ? {Foo info mixin classes} "::Fly ::nx::Class" + ? {Foo mixin guard ::Fly {1}} "" + ? {Foo info mixin classes -guards} "{::Fly -guard 1} ::nx::Class" + ? {Foo info mixin classes -guards Fly} "{::Fly -guard 1}" + Foo mixin delete ::Fly + ? {Foo info mixin classes} "::nx::Class" + + Foo class-object mixin add ::nx::Class + Foo class-object mixin add Fly + ? {Foo class-object info mixin classes} "::Fly ::nx::Class" + ? {Foo class-object mixin guard ::Fly {1}} "" + ? {Foo class-object info mixin classes -guards} "{::Fly -guard 1} ::nx::Class" + ? {Foo class-object info mixin classes -guards Fly} "{::Fly -guard 1}" + Foo class-object mixin delete ::Fly + ? {Foo class-object info mixin classes} "::nx::Class" + + ? {Foo info lookup methods superclass} "superclass" + ? {Foo info lookup method superclass} "::nsf::classes::nx::Class::superclass" + + ? {o mixin ""} "" +} + +# +# test info slots / info lookup slots +# +Test case slots { + + nx::Class create C { + :attribute a + :attribute {b 1} + } + + nx::Class create D -superclass C { + :attribute {b 2} + :attribute c + :class-object attribute a2 + :method "sub foo" args {;} + } + + D create d1 + ? {D info lookup slots} "::nx::Class::slot::object-mixin ::nx::Class::slot::mixin ::nx::Class::slot::superclass ::nx::Class::slot::object-filter ::nx::Class::slot::filter ::nx::Object::slot::class" + ? {D info slots} "::D::slot::b ::D::slot::a2 ::D::slot::c" + ? {::nx::Object info method parameter info} "" +} + +# +# test info submethod and method handles for submethods +# +Test case info-submethod { + + nx::Object create o { + :method "foo a" {} {return a} + :method "foo b" {x:int y:upper} {return b} + } + nx::Object create o2 + + nx::Class create C { + :method "bar a" {} {return a} + :method "bar b" {x:int y:upper} {return b} + :method "bar baz x" {x:int y:upper} {return x} + :method "bar baz y" {x:int y:upper} {return y} + :class-object method "foo x" {z:int} {return z} + :class-object method "foo y" {z:int} {return z} + } + + # query definition on submethod + ? {o info method definition "foo b"} {::o public method {foo b} {x:int y:upper} {return b}} + + # query definition on submethod with handle + ? {o info method definition "::o::foo b"} {::o public method {foo b} {x:int y:upper} {return b}} + + # query definition on submethod with handle + ? {o info method definition "::o::foo b"} {::o public method {foo b} {x:int y:upper} {return b}} + + # query definition on submethod with handle called on different object + ? {o2 info method definition "::o::foo b"} {::o public method {foo b} {x:int y:upper} {return b}} + + # query definition on handle of ensemble object called on different object + ? {o2 info method definition "::o::foo::b"} {::o::foo public method b {x:int y:upper} {return b}} + + # query definition on submethod with handle called on class + ? {o2 info method definition "::o::foo b"} {::o public method {foo b} {x:int y:upper} {return b}} + + # query definition on handle of ensemble object called on class + ? {o2 info method definition "::o::foo::b"} {::o::foo public method b {x:int y:upper} {return b}} + + # query definition on submethod of class + ? {::nx::Object info method definition "info lookup methods"} \ + {::nx::Object public alias {info lookup methods} ::nsf::methods::object::info::lookupmethods} + + # query definition on submethod of class with handle + ? {o info method definition "::nsf::classes::nx::Object::info lookup methods"} \ + {::nx::Object public alias {info lookup methods} ::nsf::methods::object::info::lookupmethods} + + # query definition on handle of ensemble object of class + ? {o info method definition "::nx::Object::slot::__info::lookup::methods"} \ + {::nx::Object::slot::__info::lookup public alias methods ::nsf::methods::object::info::lookupmethods} + + ? {lsort [o info method submethods dummy]} "" + ? {lsort [o info method submethods foo]} "a b" + ? {lsort [o info method submethods "foo a"]} "" + + ? {lsort [C info method submethods "bar"]} "a b baz" + ? {lsort [C info method submethods "bar a"]} "" + ? {lsort [C info method submethods "bar baz"]} "x y" + ? {lsort [C info method submethods "bar baz y"]} "" + + ? {lsort [C class-object info method submethods "foo"]} "x y" + ? {lsort [C class-object info method submethods "foo x"]} "" + + ? {C info method handle "bar"} {::nsf::classes::C::bar} + ? {C info method handle "bar a"} {::nsf::classes::C::bar a} + ? {C info method handle "bar baz y"} {::nsf::classes::C::bar baz y} + + ? {C info method definition "bar b"} {::C public method {bar b} {x:int y:upper} {return b}} + ? {C info method definition "::nsf::classes::C::bar b"} {::C public method {bar b} {x:int y:upper} {return b}} + ? {o2 info method definition "::nsf::classes::C::bar b"} {::C public method {bar b} {x:int y:upper} {return b}} + + ? {C class-object info method handle "foo"} {::C::foo} + ? {C class-object info method handle "foo x"} {::C::foo x} + + ? {C class-object info method definition "::C::foo x"} {::C public class-object method {foo x} z:int {return z}} + ? {C info method definition "::C::foo x"} {::C public class-object method {foo x} z:int {return z}} + ? {o2 info method definition "::C::foo x"} {::C public class-object method {foo x} z:int {return z}} + + ? {C info method definition "bar baz y"} \ + {::C public method {bar baz y} {x:int y:upper} {return y}} + ? {C info method definition "::nsf::classes::C::bar baz y"} \ + {::C public method {bar baz y} {x:int y:upper} {return y}} + + ? {nx::Object info method parameter "info lookup methods"} \ + "-callprotection -incontext -methodtype -nomixins -path -source pattern:optional" + ? {o info method parameter "foo b"} "x:int y:upper" + + ? {nx::Object info method parameter ::nx::Object::slot::__info::lookup::methods} \ + "-callprotection -incontext -methodtype -nomixins -path -source pattern:optional" + ? {o info method parameter "::o::foo::b"} "x:int y:upper" + + ? {nx::Object info method handle "info"} "::nsf::classes::nx::Object::info" + ? {nx::Object info method handle "info lookup methods"} \ + "::nsf::classes::nx::Object::info lookup methods" + + ? {nx::Object info method handle "::nsf::classes::nx::Object::info lookup methods"} \ + "::nsf::classes::nx::Object::info lookup methods" + + ? {o info method handle "foo b"} "::o::foo b" +} + +# +# test "info methods -path" +# +Test case info-methods-path { + # + # test case on base class + # + ? {::nx::Object info methods "info"} "info" + ? {::nx::Object info methods -path "info"} "" + ? {lsort [::nx::Object info methods -path "info lookup *"]} \ + "{info lookup filter} {info lookup method} {info lookup methods} {info lookup slots}" + ? {lsort [::nx::Object info methods -path "info *method*"]} \ + "{info filter methods} {info lookup method} {info lookup methods} {info method} {info methods}" + ? {lsort [::nx::Object info methods "slots"]} "" + ? {lsort [::nx::Object info methods "*slots*"]} "" + ? {lsort [::nx::Object info methods -path "*slots*"]} \ + "{info lookup slots} {info slots}" + ? {lsort [::nx::Object info methods -path "*filter*"]} \ + "filter {info filter guard} {info filter methods} {info lookup filter}" + + ::nx::Class create C { + :public method "string length" {s} {puts length} + :public method "string reverse" {s} {puts reverse} + :public method foo {} {puts foo} + :protected method "a b c" {} {puts "a b c"} + :protected method "a b d" {} {puts "a b d"} + :public method "a c" {d c} {puts "a c"} + :create c1 + } + nx::Class create D { + :superclass C + :public method "string length" {s} {puts length} + :public method "string compress" {s} {puts compress} + :create d1 + } + ? {lsort [C info methods -path -callprotection all]} \ + "{a b c} {a b d} {a c} foo {string length} {string reverse}" + ? {lsort [C info methods -path]} \ + "{a c} foo {string length} {string reverse}" + + # + # lookup ensemble methods + # + ? {lsort [c1 info lookup methods -path "string *"]} \ + "{string length} {string reverse}" + # + # lookup ensemble methods combined from multiple classes + # + ? {lsort [d1 info lookup methods -path "string *"]} \ + "{string compress} {string length} {string reverse}" + + # + # search for ensemble method + # + ? {lsort [d1 info lookup method "string length"]} "::nsf::classes::D::string length" + ? {lsort [d1 info lookup method "string reverse"]} "::nsf::classes::C::string reverse" + +} \ No newline at end of file Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/interceptor-slot.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/interceptor-slot.test =================================================================== diff -u --- tests/interceptor-slot.test (revision 0) +++ tests/interceptor-slot.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,185 @@ +# -*- Tcl *-* +package require nx +package require nx::test + +namespace import ::nx::* + +Class create M { + :method mfoo {} {puts [self proc]} +} +Class create M2 +Class create C + +? {C info lookup method mixin} "::nsf::classes::nx::Class::mixin" +C mixin M +? {C info precedence} "::nx::Class ::nx::Object" +? {C mixin} "::M" +? {C info mixin classes} "::M" +C create c1 +? {c1 info precedence} "::M ::C ::nx::Object" +C mixin add M2 +? {c1 info precedence} "::M2 ::M ::C ::nx::Object" +C mixin delete M2 +? {c1 info precedence} "::M ::C ::nx::Object" +C mixin delete M + +# per-object mixins +? {c1 info precedence} "::C ::nx::Object" +c1 mixin add M +? {::nsf::relation c1 object-mixin} ::M +? {catch {c1 mixin UNKNOWN}} 1 +? {::nsf::relation c1 object-mixin} "::M" + +# add again the same mixin +c1 mixin add M +? {c1 info precedence} "::M ::C ::nx::Object" +c1 mixin add M2 +? {c1 info precedence} "::M2 ::M ::C ::nx::Object" +c1 mixin delete M +? {c1 info precedence} "::M2 ::C ::nx::Object" +c1 mixin delete M2 +? {c1 info precedence} "::C ::nx::Object" + +# +# adding, removing per-object mixins for classes through relation +# "object-mixin" +# +::nsf::relation C object-mixin M +? {C info precedence} "::M ::nx::Class ::nx::Object" +? {C class-object info mixin classes} "::M" +::nsf::relation C object-mixin "" +? {C info precedence} "::nx::Class ::nx::Object" + +# +# adding, removing per-object mixins for classes through slot +# "object-mixin" +# +# C object-mixin M +# ? {C info precedence} "::M ::nx::Class ::nx::Object" +# ? {C class-object info mixin classes} "::M" +# C object-mixin "" +# ? {C info precedence} "::nx::Class ::nx::Object" + +# +# add and remove class-object mixin for classes via modifier "object" and +# "mixin" +# +C class-object mixin M +? {C info precedence} "::M ::nx::Class ::nx::Object" +? {C class-object info mixin classes} "::M" +C class-object mixin "" +? {C info precedence} "::nx::Class ::nx::Object" + +# +# add and remove class-object mixin for classes via class-object mixin add +# +C class-object mixin add M +? {C info precedence} "::M ::nx::Class ::nx::Object" +? {C class-object info mixin classes} "::M" +C class-object mixin "" +? {C info precedence} "::nx::Class ::nx::Object" + +# +# adding per-object mixins for classes via "object mixin add M" +# +C class-object mixin add M +? {C info precedence} "::M ::nx::Class ::nx::Object" +? {::nsf::relation C object-mixin} ::M +? {catch {C class-object mixin add UNKNOWN}} 1 +? {::nsf::relation C object-mixin} "::M" +C class-object mixin "" +? {C info precedence} "::nx::Class ::nx::Object" + +# +# adding per-object mixins for classes via "object mixin M" +# +C class-object mixin M +? {C info precedence} "::M ::nx::Class ::nx::Object" + +# forwarder with 0 arguments + flag +? {C class-object mixin} "::M" + + +Test case mixin-add { + + Class create M1 { + :method mfoo {} {puts [current method]} + } + Class create M11 + Class create C1 + + ? {C1 info lookup method mixin} "::nsf::classes::nx::Class::mixin" + C1 class-object mixin M1 + ? {C1 info precedence} "::M1 ::nx::Class ::nx::Object" + C1 create c11 + ? {c11 info precedence} "::C1 ::nx::Object" + C1 class-object mixin add M11 + ? {C1 info precedence} "::M11 ::M1 ::nx::Class ::nx::Object" + Object create o -mixin M1 + ? {o info precedence} "::M1 ::nx::Object" + + Class create O + O class-object mixin M1 + ? {O info precedence} "::M1 ::nx::Class ::nx::Object" + Class create O -object-mixin M1 + ? {O info precedence} "::M1 ::nx::Class ::nx::Object" +} + +Test parameter count 3 +Test case "filter-and-creation" { + Class create Foo { + :public method myfilter {args} { + set i [::incr ::count] + set s [self] + set m [current calledmethod] + #puts stderr "$i: $s.$m" + #puts stderr "$i: procsearch before [$s procsearch info]" + set r [next] + #puts stderr "$i: $s.$m got ($r)" + #puts stderr "$i: $s.$m procsearch after [$s info lookup method info]" + return $r + } + # method for testing next to non-existing shadowed method + :public method baz {} {next} + } + + ? {Foo create ob} ::ob + + # make sure, no unknown handler exists + ? {::ob info lookup method unknown} "" + + ? {ob bar} {::ob: unable to dispatch method 'bar'} + ? {ob baz} {} + + # define a global unknown handler + ::nx::Object protected method unknown {m args} { + error "[::nsf::current object]: unable to dispatch method '$m'" + } + + ? {ob bar} {::ob: unable to dispatch method 'bar'} + ? {ob baz} {} + + Foo filter myfilter + # create through filter + ? {Foo create ob} ::ob + + # unknown through filter + ? {ob bar1} {::ob: unable to dispatch method 'bar1'} + ? {ob baz} {} + + # deactivate nx unknown handler in case it exists + ::nx::Object method unknown {} {} + + # create through filter + ? {Foo create ob2} ::ob2 + + # unknown through filter + ? {ob2 bar2} {::ob2: unable to dispatch method 'bar2'} + ? {ob2 baz} {} + +} +puts stderr ======EXIT + + + + Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/method-modifiers.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/method-modifiers.test =================================================================== diff -u --- tests/method-modifiers.test (revision 0) +++ tests/method-modifiers.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,312 @@ +# -*- Tcl *-* +package require nx; namespace import ::nx::* +::nx::configure defaultMethodCallProtection false +package require nx::test + +Test parameter count 10 + +Class create C { + # methods + :method plain_method {} {return [current method]} + :public method public_method {} {return [current method]} + :protected method protected_method {} {return [current method]} + + # forwards + :forward plain_forward %self plain_method + :public forward public_forward %self public_method + :protected forward protected_forward %self protected_method + + # setter + :setter plain_setter + :public setter public_setter + :protected setter protected_setter + + # alias + :alias plain_alias [C info method handle plain_method] + :public alias public_alias [C info method handle public_method] + :protected alias protected_alias [C info method handle protected_method] + + # object + :class-object method plain_object_method {} {return [current method]} + :public class-object method public_object_method {} {return [current method]} + :protected class-object method protected_object_method {} {return [current method]} + :class-object forward plain_object_forward %self plain_object_method + :public class-object forward public_object_forward %self public_object_method + :protected class-object forward protected_object_forward %self protected_object_method + :class-object setter plain_object_setter + :public class-object setter public_object_setter + :protected class-object setter protected_object_setter + :class-object alias plain_object_alias [:class-object info method handle plain_object_method] + :public class-object alias public_object_alias [:class-object info method handle public_object_method] + :protected class-object alias protected_object_alias [:class-object info method handle protected_object_method] +} +C create c1 { + # methods + :method plain_object_method {} {return [current method]} + :public method public_object_method {} {return [current method]} + :protected method protected_object_method {} {return [current method]} + + # forwards + :forward plain_object_forward %self plain_object_method + :public forward public_object_forward %self public_object_method + :protected forward protected_object_forward %self protected_object_method + + # setter + :setter plain_object_setter + :public setter public_object_setter + :protected setter protected_object_setter + + # alias + :alias plain_object_alias [:info method handle plain_object_method] + :public alias public_object_alias [:info method handle public_object_method] + :protected alias protected_object_alias [:info method handle protected_object_method] +} +C public setter s0 +C protected setter s1 +? {c1 s0 0} 0 +? {::nsf::dispatch c1 s1 1} 1 +C class-object setter s3 +? {C s3 3} 3 + +# create a fresh object (different from c1) +C create c2 +# test scripted class level methods +Test case scripted-class-level-methods { + ? {c2 plain_method} "plain_method" + ? {c2 public_method} "public_method" + ? {catch {c2 protected_method}} 1 + ? {::nsf::dispatch c2 protected_method} "protected_method" +} + +# class level forwards +Test case class-level-forwards { + ? {c2 plain_forward} "plain_method" + ? {c2 public_forward} "public_method" + ? {catch {c2 protected_forward}} 1 + ? {::nsf::dispatch c2 protected_forward} "protected_method" +} + +# class level setter +Test case class-level-setter { + ? {c2 plain_setter 1} "1" + ? {c2 public_setter 2} "2" + ? {catch {c2 protected_setter 3}} 1 + ? {::nsf::dispatch c2 protected_setter 4} "4" +} + +# class level alias ....TODO: wanted behavior of [current method]? not "plain_alias"? +Test case class-level-alias { + ? {c2 plain_alias} "plain_method" + ? {c2 public_alias} "public_method" + ? {catch {c2 protected_alias}} 1 + ? {::nsf::dispatch c2 protected_alias} "protected_method" +} + +########### + +# scripted class-object level methods +Test case scripted-class-object-level { + ? {C plain_object_method} "plain_object_method" + ? {C public_object_method} "public_object_method" + ? {catch {C protected_object_method}} 1 + ? {::nsf::dispatch C protected_object_method} "protected_object_method" +} + +# class-object level forwards +Test case class-object-level-forwards { + ? {C plain_object_forward} "plain_object_method" + ? {C public_object_forward} "public_object_method" + ? {catch {C protected_object_forward}} 1 + ? {::nsf::dispatch C protected_object_forward} "protected_object_method" +} + +# class-object level setter +Test case class-object-level-setter { + ? {C plain_object_setter 1} "1" + ? {C public_object_setter 2} "2" + ? {catch {C protected_object_setter 3}} 1 + ? {::nsf::dispatch C protected_object_setter 4} "4" +} + +# class-object level alias ....TODO: wanted behavior of [current method]? not "plain_alias"? +Test case class-object-level-alias { + ? {C plain_object_alias} "plain_object_method" + ? {C public_object_alias} "public_object_method" + ? {catch {C protected_object_alias}} 1 + ? {::nsf::dispatch C protected_object_alias} "protected_object_method" +} + +########### + +# scripted object level methods +Test case scripted-object-level-methods { + ? {c1 plain_object_method} "plain_object_method" + ? {c1 public_object_method} "public_object_method" + ? {catch {c1 protected_object_method}} 1 + ? {::nsf::dispatch c1 protected_object_method} "protected_object_method" +} + +# object level forwards +Test case object-level-forwards { + ? {c1 plain_object_forward} "plain_object_method" + ? {c1 public_object_forward} "public_object_method" + ? {catch {c1 protected_object_forward}} 1 + ? {::nsf::dispatch c1 protected_object_forward} "protected_object_method" +} + +# object level setter +Test case object-level-setter +? {c1 plain_object_setter 1} "1" +? {c1 public_object_setter 2} "2" +? {catch {c1 protected_object_setter 3}} 1 +? {::nsf::dispatch c1 protected_object_setter 4} "4" + +# object level alias ....TODO: wanted behavior of [current method]? not "plain_alias"? +Test case object-level-alias { + ? {c1 plain_object_alias} "plain_object_method" + ? {c1 public_object_alias} "public_object_method" + ? {catch {c1 protected_object_alias}} 1 + ? {::nsf::dispatch c1 protected_object_alias} "protected_object_method" + + ? {lsort [c1 info methods]} \ + "plain_object_alias plain_object_forward plain_object_method plain_object_setter public_object_alias public_object_forward public_object_method public_object_setter" + ? {lsort [C class-object info methods]} \ + "plain_object_alias plain_object_forward plain_object_method plain_object_setter public_object_alias public_object_forward public_object_method public_object_setter s3" +} + +C destroy + +Test case mixinguards { + # define a Class C and mixin class M + Class create C + Class create M + + # register the mixin on C as a class mixin and define a mixinguard + C mixin M + C mixin guard M {1 == 1} + ? {C info mixin guard M} "1 == 1" + C mixin guard M {} + ? {C info mixin guard M} "" + + # now the same as class-object mixin and class-object mixin guard + C class-object mixin M + C class-object mixin guard M {1 == 1} + ? {C class-object info mixin guard M} "1 == 1" + C class-object mixin guard M {} + ? {C class-object info mixin guard M} "" +} + +Test case mixin-via-objectparam { + # add an object and class mixin via object-parameter and via slots + Class create M1; Class create M2; Class create M3; Class create M4 + Class create C -mixin M1 -object-mixin M2 { + :mixin add M3 + :class-object mixin add M4 + } + + ? {lsort [C class-object info mixin classes]} "::M2 ::M4" + ? {lsort [C info mixin classes]} "::M1 ::M3" + C destroy + M1 destroy; M2 destroy; M3 destroy; M4 destroy; +} + +# testing next via nonpos-args +Test case next-from-nonpos-args { + + Object create o { + :method bar {-y:required -x:required} { + #puts stderr "+++ o x=$x, y=$y [current args] ... next [current next]" + return [list x $x y $y [current args]] + } + } + Class create M { + :method bar {-x:required -y:required} { + #puts stderr "+++ M x=$x, y=$y [current args] ... next [current next]" + return [list x $x y $y [current args] -- {*}[next]] + } + } + + o mixin M + ? {o bar -x 13 -y 14} "x 13 y 14 {-x 13 -y 14} -- x 13 y 14 {-x 13 -y 14}" + ? {o bar -y 14 -x 13} "x 13 y 14 {-y 14 -x 13} -- x 13 y 14 {-y 14 -x 13}" +} + +# +# test method attribute with protected/public +# +Test case attribute-method { + + Class create C { + set x [:attribute a] + + ? [list set _ $x] "::nsf::classes::C::a" + + # attribute with default + :attribute {b b1} + :public attribute {c c1} + :protected attribute {d d1} + + set X [:class-object attribute A] + ? [list set _ $X] "::C::A" + + # class-object attribute with default + :class-object attribute {B B2} + :public class-object attribute {C C2} + :protected class-object attribute {D D2} + } + + C create c1 -a 1 + ? {c1 a} 1 + ? {c1 b} b1 + ? {c1 c} c1 + ? {c1 d} "::c1: unable to dispatch method 'd'" + + ? {C A 2} 2 + ? {C B} B2 + ? {C C} C2 + ? {C D} "Method 'D' unknown for ::C. Consider '::C create D ' instead of '::C D '" + + Object create o { + set x [:attribute a] + ? [list set _ $x] "::o::a" + + # attribute with default + :attribute {b b1} + :public attribute {c c1} + :protected attribute {d d1} + } + ? {o a 2} 2 + ? {o b} b1 + ? {o c} c1 + ? {o d} "::o: unable to dispatch method 'd'" +} + +Test case subcmd { + + Class create Foo { + + :method "Info filter guard" {filter} {return [current object]-[current method]} + :method "Info filter methods" {-guards pattern:optional} {return [current object]-[current method]} + :method "Info args" {} {return [current object]-[current method]} + :method "Info foo" {} {return [current object]-[current method]} + + :class-object method "INFO filter guard" {a b} {return [current object]-[current method]} + :class-object method "INFO filter methods" {-guards pattern:optional} {return [current object]-[current method]} + } + + ? {Foo INFO filter guard 1 2} ::Foo-guard + ? {Foo INFO filter methods a*} ::Foo-methods + + Foo create f1 { + :method "list length" {} {return [current object]-[current method]} + :method "list reverse" {} {return [current object]-[current method]} + } + + ? {f1 Info filter guard x} "::f1-guard" + ? {f1 Info filter methods} "::f1-methods" + ? {f1 Info args} "::f1-args" + ? {f1 Info foo} "::f1-foo" + + ? {f1 list length} "::f1-length" + ? {f1 list reverse} "::f1-reverse" +} Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/method-require.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/method-require.test =================================================================== diff -u --- tests/method-require.test (revision 0) +++ tests/method-require.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,59 @@ +# -*- Tcl *-* +package require nx +package require nx::test + +Test parameter count 10 +Test case method-require { + + # + # A few method-provides + # + # Some provides could be in e.g. nx.tcl, some could be loaded via + # package require. We could as well think about an auto-indexer + # producing these.... + # + + nsf::provide_method append {::nsf::alias append -frame object ::append} + nsf::provide_method lappend {::nsf::alias lappend -frame object ::lappend} + nsf::provide_method set {::nsf::alias set -frame object ::set} + nsf::provide_method tcl::set {::nsf::alias set -frame object ::set} + nsf::provide_method exists {::nsf::alias exists ::nsf::methods::object::exists} + nsf::provide_method foo {::nsf::method foo {x y} {return x=$x,y=$y}} + nsf::provide_method x {::nsf::mixin ::MIX} { + # here could be as well a package require, etc. + ::nx::Class create ::MIX {:public method x {} {return x}} + } + + # + # Lets try it out: + # + + nx::Class create C { + :require method set + :require method exists + + # required names can be different from registered names; if there + # are multiple set methods, we could point to the right one + :require method tcl::set + + # object methods: + :require class-object method lappend + + # a scripted method + :require class-object method foo + + :require class-object method x + + # looks as well ok: + :require namespace + } + + C create c1 + ? {c1 set x 100} 100 + ? {c1 exists x} 1 + ? {C lappend some_list e1 e2} "e1 e2" + ? {C foo 1 2} x=1,y=2 + ? {C x} x +} + + Index: tests/mixinof.test =================================================================== diff -u --- tests/mixinof.test (revision 0) +++ tests/mixinof.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,515 @@ +# -*- Tcl *-* +# testing mixinof +package require nx; namespace import ::nx::* +package require nx::test + +########################################### +# testing simple per object mixins +########################################### +Class create A +Object create o -mixin A +? {o mixin} ::A +? {o info mixin classes} ::A +? {A info mixinof} ::o + +o destroy +? {A info mixinof} "" + +A destroy + +########################################### +# testing transitive per object mixins +########################################### + +Class create B +Class create C -superclass B + +Class create M +B mixin M + +Object create o -mixin C +Object create o1 -mixin B +? {C info mixinof} ::o +? {lsort [B info mixinof -closure]} "::o ::o1" +? {lsort [B info mixinof -closure ::o1]} "::o1" +? {lsort [B info mixinof -closure ::o*]} "::o ::o1" +? {lsort [C info mixinof -closure ::o*]} "::o" +# A class is mixed into a per-object mixin class +? {lsort [M info mixinof -closure ::o*]} "::o ::o1" +? {lsort [M info mixinof -scope object]} "" + +M destroy +B destroy +C destroy +::o destroy +::o1 destroy + +########################################### +# testing per object mixins with redefinition +########################################### +Class create M {:method foo args {puts x;next}} +Object create o -mixin M + +? {o info mixin classes} ::M +? {o info precedence} "::M ::nx::Object" +? {o info lookup method foo} "::nsf::classes::M::foo" + +Class create M {:method foo args next} +? {o info mixin classes} ::M +? {o info precedence} "::M ::nx::Object" +? {o info lookup method foo} "::nsf::classes::M::foo" + +M destroy +? {o info mixin classes} "" +? {o info precedence} "::nx::Object" +? {o info lookup method foo} "" + +o destroy + +########################################### +# testing simple per class mixins +########################################### +Test case pcm +Class create A +Class create B -mixin A +Class create C -superclass B +C create c1 + +? {B mixin} ::A +? {B info mixin classes} ::A +? {A info mixinof} ::B +? {c1 info precedence} "::A ::C ::B ::nx::Object" + +B destroy +? {A info mixinof} "" +? {c1 info precedence} "::C ::nx::Object" + +A destroy +C destroy +c1 destroy + +########################################### +# testing simple per class mixins with guards +########################################### +Test case pcm2 +Class create M1 +Class create M2 +Class create X +Class create A -mixin {M1 M2 X} +A mixin guard M1 "test" +Class create B -superclass A +? {A info mixin classes M2} ::M2 +? {A info mixin classes M*} "::M1 ::M2" +? {A info mixin classes -guards} "{::M1 -guard test} ::M2 ::X" +? {B info mixin classes} "" +? {B info mixin classes -closure} "::M1 ::M2 ::X" +? {B info mixin classes -closure M2} ::M2 +? {B info mixin classes -closure M*} "::M1 ::M2" +? {B info mixin classes -closure -guards} "{::M1 -guard test} ::M2 ::X" +? {B info mixin classes -closure -guards M1} "{::M1 -guard test}" +? {B info mixin classes -closure -guards M*} "{::M1 -guard test} ::M2" +A destroy +B destroy +X destroy +M1 destroy +M2 destroy + +########################################### +# testing transitive per class mixins +########################################### +Test case trans-pcm1 +Class create A +Class create B -mixin A +Class create C -superclass B +A mixin [Class create M] + +A create a1 +B create b1 +C create c1 + +? {B mixin} ::A +? {B info mixin classes} ::A +? {A info mixinof -scope class} ::B +? {a1 info precedence} "::M ::A ::nx::Object" +? {b1 info precedence} "::M ::A ::B ::nx::Object" +? {c1 info precedence} "::M ::A ::C ::B ::nx::Object" + +? {M info mixinof -scope class} "::A" +# since M is an instmixin of A and A is a instmixin of B, +# M is a instmixin of B as well, and of its subclasses +? {M info mixinof -scope class -closure} "::A ::B ::C" +? {A info mixinof -scope class} "::B" +? {A info mixinof -scope class -closure} "::B ::C" +? {B info mixinof -scope class} "" +? {B info mixinof -scope class -closure} "" + +# and now destroy mixin classes +M destroy +? {a1 info precedence} "::A ::nx::Object" +? {b1 info precedence} "::A ::B ::nx::Object" +? {c1 info precedence} "::A ::C ::B ::nx::Object" + +B destroy +? {A info mixinof -scope class} "" +? {c1 info precedence} "::C ::nx::Object" + +foreach o {A C a1 b1 c1} { $o destroy } + + +########################################### +# testing transitive per class mixins with subclasses +########################################### +Test case trans-pcm2 +Class create X +Class create D +Class create C -superclass D +Class create A -mixin C +Class create B -superclass A +B create b1 + +? {C info mixinof -scope class -closure} "::A ::B" +? {D info mixinof -scope class -closure} "" +? {A info mixinof -scope class -closure} "" +? {B info mixinof -scope class -closure} "" +? {X info mixinof -scope class -closure} "" +D mixin X +? {C info mixinof -scope class -closure} "::A ::B" +? {D info mixinof -scope class -closure} "" +? {A info mixinof -scope class -closure} "" +? {B info mixinof -scope class -closure} "" +? {X info mixinof -scope class -closure} "::D ::C ::A ::B" +? {b1 info precedence} "::C ::X ::D ::B ::A ::nx::Object" +B create b2 +? {b2 info precedence} "::C ::X ::D ::B ::A ::nx::Object" + +foreach o {X D C A B b1 b2} {$o destroy} + +########################################### +# testing transitive per class mixins with subclasses +########################################### +Test case trans-pcm3 +Class create A3 -superclass [Class create A2 -superclass [Class create A1]] +Class create B3 -superclass [Class create B2 -superclass [Class create B1 -superclass [Class create B0]]] +Class create C3 -superclass [Class create C2 -superclass [Class create C1]] + +A2 mixin B2 +B1 mixin C2 + +? {A1 info mixinof -scope class -closure} "" +? {A2 info mixinof -scope class -closure} "" +? {A3 info mixinof -scope class -closure} "" + +? {B0 info mixinof -scope class -closure} "" +? {B1 info mixinof -scope class -closure} "" +? {B2 info mixinof -scope class -closure} "::A2 ::A3" +? {B3 info mixinof -scope class -closure} "" + +? {C1 info mixinof -scope class -closure} "" +? {C2 info mixinof -scope class -closure} "::B1 ::B2 ::B3 ::A2 ::A3" +? {C3 info mixinof -scope class -closure} "" + +foreach o {A1 A2 A3 B0 B1 B2 B3 C1 C2 C3} {$o destroy} + +########################################### +# testing transitive per class mixins with destroy +########################################### +Test case pcm-trans-destroy-A +Class create A -mixin [Class create M] +Class create B -mixin A +Class create C -superclass B + +A create a1 +B create b1 +C create c1 + +? {B mixin} ::A +? {B info mixin classes} ::A +? {A info mixinof -scope class} ::B +? {a1 info precedence} "::M ::A ::nx::Object" +? {b1 info precedence} "::M ::A ::B ::nx::Object" +? {c1 info precedence} "::M ::A ::C ::B ::nx::Object" + +# and now destroy A +A destroy +? {a1 info precedence} "::nx::Object" +? {b1 info precedence} "::B ::nx::Object" +? {c1 info precedence} "::C ::B ::nx::Object" + +? {M info mixinof} "" +? {M info mixinof -closure} "" + +B destroy +? {M info mixinof -scope class} "" +? {c1 info precedence} "::C ::nx::Object" + +foreach o {M C a1 b1 c1} { $o destroy } + +########################################### +# testing transitive per class mixins with destroy +########################################### +Test case pcm-trans-destroy-B +Class create A -mixin [Class create M] +Class create B -mixin A +Class create C -superclass B + +A create a1 +B create b1 +C create c1 + +? {B mixin} ::A +? {B info mixin classes} ::A +? {A info mixinof -scope class} ::B +? {a1 info precedence} "::M ::A ::nx::Object" +? {b1 info precedence} "::M ::A ::B ::nx::Object" +? {c1 info precedence} "::M ::A ::C ::B ::nx::Object" + +B destroy +? {a1 info precedence} "::M ::A ::nx::Object" +? {b1 info precedence} "::nx::Object" +? {c1 info precedence} "::C ::nx::Object" + +? {M info mixinof -scope class} "::A" +? {M info mixinof -scope class -closure} "::A" +? {A info mixinof -scope class} "" + +foreach o {M C a1 b1 c1} { + $o destroy +} + +########################################### +# testing simple per class mixins with redefinition +########################################### +Test case pcm-redefine +Class create A +Class create B -mixin A +Class create C -superclass B +C create c1 + +? {B mixin} ::A +? {B info mixin classes} ::A +? {A info mixinof -scope class} ::B +? {c1 info precedence} "::A ::C ::B ::nx::Object" +? {B info heritage} "::nx::Object" +? {C info heritage} "::B ::nx::Object" + +Class create B -mixin A + +? {B info heritage} "::nx::Object" +? {C info heritage} "::nx::Object" +? {B mixin} ::A +? {B info mixin classes} ::A +? {A info mixinof} ::B +? {c1 info precedence} "::C ::nx::Object" + +B destroy +? {A info mixinof} "" +? {c1 info precedence} "::C ::nx::Object" + +A destroy +C destroy +c1 destroy + + +########################################### +# testing simple per class mixins with +# redefinition and softrecreate +########################################### +Test case pcm-redefine-soft +::nsf::configure softrecreate true +Class create A +Class create B -mixin A +Class create C -superclass B +C create c1 + +? {B mixin} ::A +? {B info mixin classes} ::A +? {A info mixinof -scope class} ::B +? {c1 info precedence} "::A ::C ::B ::nx::Object" +? {C info heritage} "::B ::nx::Object" +? {B info heritage} "::nx::Object" + +Class create B -mixin A +? {C info heritage} "::B ::nx::Object" +? {B info heritage} "::nx::Object" +? {B info mixin classes} ::A +? {A info mixinof -scope class} ::B +? {c1 info precedence} "::A ::C ::B ::nx::Object" + +B destroy +? {A info mixinof -scope class} "" +? {c1 info precedence} "::C ::nx::Object" + +A destroy +C destroy +c1 destroy + + +########################################### +# test of recreate with same superclass, +# with softrecreate off +########################################### +Test case precedence +::nsf::configure softrecreate false +Class create O +Class create A -superclass O +Class create B -superclass A +B create b1 +A create a1 +O create o1 +? {A info superclass} "::O" +? {B info heritage} "::A ::O ::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" +? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::A ::O ::nx::Object" +? {b1 info precedence} "::B ::A ::O ::nx::Object" +# we recreate the class new, with the same superclass +Class create A -superclass O +? {A info superclass} "::O" +? {B info heritage} "::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "{} {} ::A" +? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::nx::Object ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::nx::Object ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::nx::Object" +? {b1 info precedence} "::B ::nx::Object" +foreach o {A O B a1 b1 o1} {$o destroy} + +########################################### +# test of recreate with different superclass +# with softrecreate on +########################################### +Test case alternate-precedence +::nsf::configure softrecreate false +Class create O +Class create A -superclass O +Class create B -superclass A +B create b1 +A create a1 +O create o1 +? {A info superclass} "::O" +? {B info heritage} "::A ::O ::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" +? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::A ::O ::nx::Object" +? {b1 info precedence} "::B ::A ::O ::nx::Object" +# we recreate the class new, with a different superclass +Class create A +? {A info superclass} "::nx::Object" +? {B info heritage} "::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "{} {} {}" +? {list [A info superclass] [B info superclass] [O info superclass]} "::nx::Object ::nx::Object ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::nx::Object ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::nx::Object" +? {b1 info precedence} "::B ::nx::Object" +foreach o {A O B a1 b1 o1} {$o destroy} + + +########################################### +# test of recreate with same superclass, +# with softrecreate on +########################################### +Test case recreate-precedence +::nsf::configure softrecreate true +Class create O +Class create A -superclass O +Class create B -superclass A +B create b1 +A create a1 +O create o1 +? {A info superclass} "::O" +? {B info heritage} "::A ::O ::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" +? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::A ::O ::nx::Object" +? {b1 info precedence} "::B ::A ::O ::nx::Object" +# we recreate the class new, with the same superclass +Class create A -superclass O +? {A info superclass} "::O" +? {B info heritage} "::A ::O ::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" +? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::A ::O ::nx::Object" +? {b1 info precedence} "::B ::A ::O ::nx::Object" +foreach o {A O B a1 b1 o1} {$o destroy} + +########################################### +# test of recreate with different superclass +# with softrecreate on +########################################### +Test case recreate-alternate-precedence +::nsf::configure softrecreate true +Class create O +Class create A -superclass O +Class create B -superclass A +B create b1 +A create a1 +O create o1 +? {B info heritage} "::A ::O ::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} ::A" +? {list [A info superclass] [B info superclass] [O info superclass]} "::O ::A ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::A ::O ::nx::Object" +? {b1 info precedence} "::B ::A ::O ::nx::Object" +# we recreate the class new, with a different superclass +Class create A +? {A info superclass} "::nx::Object" +? {B info heritage} "::A ::nx::Object" +? {B info heritage} "::A ::nx::Object" +? {list [A info subclass] [B info subclass] [O info subclass]} "::B {} {}" +? {list [A info superclass] [B info superclass] [O info superclass]} "::nx::Object ::A ::nx::Object" +? {list [a1 info class] [b1 info class] [o1 info class]} "::A ::B ::O" +? {o1 info precedence} "::O ::nx::Object" +? {a1 info precedence} "::A ::nx::Object" +? {b1 info precedence} "::B ::A ::nx::Object" +foreach o {A O B a1 b1 o1} {$o destroy} + +#foreach o [::nx::test::Test info instances] {$o destroy} +#::nx::test::Test destroy +#puts [lsort [::nx::Object allinstances]] + +namespace import -force ::nx::* +########################################### +# testing simple per object mixins +########################################### +Test case nx-mixinof { + Class create M + Class create A + Class create C + C create c1 -mixin A + C create c2 + Class create C2 -mixin A + C2 create c22 + + ? {c1 mixin} ::A + ? {c1 info mixin classes} ::A + ? {lsort [A info mixinof]} "::C2 ::c1" + ? {M info mixinof} "" + C mixin M + #? {M info mixinof -scope object} "::c1 ::c2" + ? {M info mixinof -scope object} "" + ? {M info mixinof -scope class} "::C" + ? {M info mixinof -scope all} "::C" + ? {M info mixinof} "::C" + + ? {lsort [A info mixinof]} "::C2 ::c1" + ? {A info mixinof -scope object} "::c1" + ? {A info mixinof -scope class} "::C2" + + c1 destroy + ? {A info mixinof} "::C2" + ? {M info mixinof} "::C" + C destroy + ? {M info mixinof} "" +} + + Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/mixinoftest.tcl'. Fisheye: No comparison available. Pass `N' to diff? Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/object-system.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/object-system.test =================================================================== diff -u --- tests/object-system.test (revision 0) +++ tests/object-system.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,215 @@ +# -*- Tcl *-* +package require nx +namespace import nx::* +# +# Basic tests of the object system, should not require Class Test, +# since even class Test might not work at that time. +# +proc ? {cmd expected {msg ""}} { + #puts "??? $cmd" + set r [uplevel $cmd] + if {$msg eq ""} {set msg $cmd} + if {$r ne $expected} { + puts stderr "ERROR $msg returned '$r' ne '$expected'" + error "FAILED $msg returned '$r' ne '$expected'" + } else { + puts stderr "OK $msg" + } +} + +? {::nsf::isobject Object} 1 +? {::nsf::is class Object} 1 +? {::nsf::is metaclass Object} 0 +? {Object info superclass} "" +? {Object info class} ::nx::Class + +? {::nsf::isobject Class} 1 +? {::nsf::is class Class} 1 +? {::nsf::is metaclass Class} 1 +? {Class info superclass} ::nx::Object +? {Class info class} ::nx::Class + + +Object create o +? {::nsf::isobject Object} 1 +? {::nsf::is class o} 0 +? {::nsf::is metaclass o} 0 +? {o info class} ::nx::Object +? {Object info instances o} ::o +? {Object info instances ::o} ::o + +Class create C0 +? {::nsf::is class C0} 1 +? {::nsf::is metaclass C0} 0 +? {C0 info superclass} ::nx::Object +? {C0 info class} ::nx::Class +#? {lsort [Class info vars]} "__default_metaclass __default_superclass" + +Class create M -superclass ::nx::Class +? {::nsf::isobject M} 1 +? {::nsf::is class M} 1 +? {::nsf::is metaclass M} 1 +? {M info superclass} ::nx::Class +? {M info class} ::nx::Class + +M create C +? {::nsf::isobject C} 1 +? {::nsf::is class C} 1 +? {::nsf::is metaclass C} 0 +? {C info superclass} ::nx::Object +? {C info class} ::M + +C create c1 +? {::nsf::isobject c1} 1 +? {::nsf::is class c1} 0 +? {::nsf::is metaclass c1} 0 +? {c1 info class} ::C + +Class create M2 -superclass M +? {::nsf::isobject M2} 1 +? {::nsf::is class M2} 1 +? {::nsf::is metaclass M2} 1 +? {M2 info superclass} ::M +? {M2 info class} ::nx::Class + +M2 create m2 +? {m2 info superclass} ::nx::Object +? {m2 info class} ::M2 + +# destroy meta-class M, reclass meta-class instances to the base +# meta-class and set subclass of M to the root meta-class +M destroy +? {::nsf::isobject C} 1 +? {::nsf::is class C} 1 +? {::nsf::is metaclass C} 0 +? {C info superclass} ::nx::Object +? {C info class} ::nx::Class + +? {::nsf::is metaclass M2} 1 +? {M2 info superclass} ::nx::Class +? {m2 info superclass} ::nx::Object +? {m2 info class} ::M2 + + +# destroy class M, reclass class instances to the base class +C destroy +? {::nsf::isobject c1} 1 +? {::nsf::is object c1} 1 +? {::nsf::is class c1} 0 +? {::nsf::is metaclass c1} 0 +? {c1 info class} ::nx::Object + +# basic attributes tests + +Class create C -attributes {{x 1} {y 2}} +? {::nsf::isobject C} 1 +? {::nsf::isobject C::slot} 1 +? {C info children} ::C::slot + +C copy X +? {::nsf::isobject X} 1 +? {X info vars} "" +? {C info vars} "" +? {::nsf::isobject X::slot} 1 + +#? {C::slot info vars} __parameter +? {C info attributes} {{x 1} {y 2}} + +#? {X::slot info vars} __parameter +? {X info attributes} {{x 1} {y 2}} + +# +# tests for the dispatch command + +Object create o +o method foo {} {return goo} +o method bar {x} {return goo-$x} + +# dispatch without colon names +::nsf::dispatch o eval set :x 1 +? {o info vars} x "simple dispatch has set variable x" +? {::nx::var set o x} 1 "simple dispatch has set variable x to 1" +? {::nsf::dispatch o foo} "goo" "simple dispatch with one arg works" +? {::nsf::dispatch o bar 1} "goo-1" "simple dispatch with two args works" +o destroy + +# dispatch with colon names +Object create o {set :x 1} +::nsf::dispatch ::o ::incr x +? {o eval {set :x}} 1 "cmd dispatch without -frame object did not modify the instance variable" +::nsf::dispatch ::o -frame object ::incr x +? {o eval {set :x}} 2 "cmd dispatch -frame object modifies the instance variable" +? {catch {::nsf::dispatch ::o -frame object ::xxx x}} 1 "cmd dispatch with unknown command" +o destroy + +Object create o { + :public method foo {} { + foreach var [list x1 y1 x2 y2 x3 y3] { + lappend results $var [info exists :$var] + } + return $results + } +} +::nsf::dispatch o ::eval {set x1 1; set :y1 1} +::nsf::dispatch o -frame method ::eval {set x2 1; set :y2 1} +::nsf::dispatch o -frame object ::eval {set x3 1; set :y3 1} +? {o foo} "x1 0 y1 0 x2 0 y2 1 x3 1 y3 1" +o destroy + +puts stderr ===MINI-OBJECTSYSTEM +# test object system +# create a minimal object system without internally dipatched methods +::nsf::createobjectsystem ::object ::class + +? {::nsf::isobject ::object} 1 +? {::nsf::is class ::object} 1 +? {::nsf::is metaclass ::object} 0 +? {::nsf::relation ::object class} ::class +? {::nsf::relation ::object superclass} "" + +? {::nsf::isobject ::class} 1 +? {::nsf::is class ::class} 1 +? {::nsf::is metaclass ::class} 1 +? {::nsf::relation ::class class} ::class +? {::nsf::relation ::class superclass} ::object + +# define non-standard methos to create/destroy objects and classes +::nsf::alias ::class + ::nsf::methods::class::create +::nsf::alias ::object - ::nsf::methods::object::destroy + +# create a class named C +::class + C + +? {::nsf::isobject ::C} 1 +? {::nsf::is class ::C} 1 +? {::nsf::is metaclass ::C} 0 +? {::nsf::relation ::C class} ::class +? {::nsf::relation ::C superclass} ::object + +# create an instance of C +C + c1 + +? {::nsf::isobject ::c1} 1 +? {::nsf::is class ::c1} 0 +? {::nsf::is metaclass ::c1} 0 +? {::nsf::relation ::c1 class} ::C + +# destroy instance and class +c1 - + +? {::nsf::isobject ::c1} 0 +? {::nsf::is class ::C} 1 + +C - + +? {::nsf::isobject ::C} 0 + +::nx::Class create ::C + +? {catch {::C info has type ::UNKNOWN}} 1 +? {catch {::C info has type ::xyz::Bar}} 1 +#? {catch {::nsf::is type ::CCCC ::nx::Object}} 1 + +::C destroy + +puts stderr ===EXIT Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/parameters.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/parameters.test =================================================================== diff -u --- tests/parameters.test (revision 0) +++ tests/parameters.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,1317 @@ +# -*- Tcl *-* +package require nx +package require nx::test +#::nx::configure defaultMethodCallProtection false +namespace import ::nx::* + +Test case dummy { + ? {::namespace current} :: + set o [Object create o] + + ? {::nsf::isobject ::o} 1 +} +? {::nsf::isobject ::o} 0 + +####################################################### +# parametercheck +####################################################### +Test parameter count 1000 +Test case parametercheck { + + Object create o1 + Class create C -attributes {a {b:boolean} {c 1}} + C create c1 + Class create M + c1 mixin M + + ? {::nsf::isobject o1} 1 + ? {::nsf::isobject o1000} 0 + + ? {::nsf::is class C} 1 + ? {C info is class} 1 + + ? {::nsf::is baseclass ::nx::Object} 1 + ? {::nx::Object info is baseclass} 1 + ? {::nsf::is baseclass C} 0 + ? {C info is baseclass} 0 + + ? {::nsf::is class ::nx::Object} 1 + ? {::nsf::is ::nx::Object class} {invalid value constraints "::nx::Object"} + + ? {::nsf::is object o1} 1 + ? {::nsf::is object o1} 1 + ? {::nsf::is object o1000} 0 + ? {::nsf::is -complain object o1000} {expected object but got "o1000" for parameter value} + ? {::nsf::is integer 1} 1 + ? {::nsf::is object,type=::C c1} 1 + ? {::nsf::is -complain object,type=::C o} {expected object but got "o" for parameter value} + ? {::nsf::is object,type=::C o} 0 + + ? {c1 info has mixin ::M} 1 + ? {c1 info has mixin ::M1} {expected class but got "::M1" for parameter class} + + ? {c1 info has type C} 1 + ? {c1 info has type C1} {expected class but got "C1" for parameter class} + + ? {c1 ::nsf::methods::object::info::hastype C} 1 + ? {::nsf::dispatch c1 ::nsf::methods::object::info::hastype C} 1 + + ? {::nsf::is object o1} 1 + ? {::nsf::is object o100} 0 + ? {::nsf::is integer 1} 1 + ? {::nsf::is object,type=::C c1} 1 + ? {::nsf::is object,type=::C o} 0 + + # test built-in converter via ::nsf::is + ? {::nsf::is boolean 1} 1 + ? {::nsf::is boolean on} 1 + ? {::nsf::is boolean true} 1 + ? {::nsf::is boolean t} 1 + ? {::nsf::is boolean f} 1 + ? {::nsf::is boolean a} 0 + + ? {::nsf::is integer 0x0} 1 + ? {::nsf::is integer 0xy} 0 + + # built in converter, but not allowed + ? {::nsf::is switch 1} {invalid value constraints "switch"} + ? {::nsf::is superclass M} {invalid value constraints "superclass"} + + # don't allow convert; + # well we have to allow it, since "-returns" uses the same mechanism + #? {::nsf::is integer,convert 1} {invalid value constraints "integer,convert"} + + # tcl checker + ? {::nsf::is upper ABC} 1 + ? {::nsf::is upper Abc} 0 + ? {::nsf::is lower Abc} 0 + ? {::nsf::is lower abc} 1 + + #? {::nsf::is type c1 C} 1 + #? {::nsf::is type o C} 0 + #? {::nsf::is object o -type C} 0 + #? {::nsf::is object o -hasmixin C} 0 + + # scripted checker + ? {::nsf::is metaclass ::nx::Class} 1 + ? {::nsf::is metaclass ::nx::Object} 0 + + ? {::nsf::is -complain class o1} {expected class but got "o1" for parameter value} + ? {::nsf::is class o1} 0 + ? {::nsf::is -complain class Test} 1 + ? {::nsf::is -complain object,multivalued [list o1 Test]} 1 + + ? {::nsf::is -complain integer,multivalued [list 1 2 3]} 1 + ? {::nsf::is -complain integer,multivalued [list 1 2 3 a]} \ + {invalid value in "1 2 3 a": expected integer but got "a" for parameter value} + ? {::nsf::is -complain object,type=::C c1} 1 + ? {::nsf::is -complain object,type=::C o} \ + {expected object but got "o" for parameter value} \ + "object, but different type" + ? {::nsf::is -complain object,type=::C c} \ + {expected object but got "c" for parameter value} \ + "no object" + ? {::nsf::is -complain object,type=::nx::Object c1} 1 "general type" + + # do not allow "currently unknown" user defined types in parametercheck + ? {::nsf::is -complain in1 aaa} {invalid value constraints "in1"} + + ? {::nsf::is -complain lower c} 1 "lower case char" + ? {::nsf::is -complain lower abc} 1 "lower case chars" + ? {::nsf::is -complain lower Abc} {expected lower but got "Abc" for parameter value} + ? {string is lower abc} 1 "tcl command 'string is lower'" + + ? {::nsf::is -complain {i:integer 1} 2} {invalid value constraints "i:integer 1"} +} + +Test parameter count 10 +Test case multiple-method-checkers { + Object create o { + :public method foo {} { + ::nsf::is metaclass ::XYZ + ::nsf::is metaclass ::nx::Object + } + + :public method bar {} { + ::nsf::is metaclass ::XYZ + ::nsf::is metaclass ::XYZ + } + + :public method bar2 {} { + ::nsf::is metaclass ::nx::Object + ::nsf::is metaclass ::nx::Object + } + } + + ? {o foo} 0 + ? {o bar} 0 + + ? {::nsf::is metaclass ::XYZ} 0 + ? {::nsf::is metaclass ::nx::Object} 0 + + ? {o foo} 0 + ? {o bar2} 0 +} + +####################################################### +# parametercheck +####################################################### +Test parameter count 10000 +Test case parametercheck { + + Object create ::paramManager { + :method type=sex {name value} { + return "agamous" + } + } + + ? {::nsf::is -complain sex,slot=::paramManager female} "1" +} +####################################################### +# cononical feature table +####################################################### +# +# parameter options +# required +# optional +# multivalued +# noarg +# arg= +# substdefault: if no value given, subst on default (result is substituted value); +# susbt cmd can use variable resolvers, +# works for scripted/c-methods and obj-parm, +# autmatically set by "$slot toParameterSyntax" if default contains "[" ... "]". +# +# initcmd: evaluate body in an xotcl nonleaf frame, called via configure +# (example: last arg on create) +# method call specified method in an xotcl nonleaf frame, called via configure; +# specified value is the first argument unless "noarg" is used +# (example: -noinit). +# +# parameter type multivalued required noarg type= arg= parametercheck methodParm objectParm +# initcmd NO YES NO NO NO NO NO/POSSIBLE YES +# method NO YES YES NO YES NO NO/POSSIBLE YES +# +# relation NO YES NO NO YES NO NO YES +# stringtype YES YES NO NO NO YES YES YES +# +# switch NO NO NO NO NO NO YES YES +# integer YES YES NO NO NO YES YES YES +# boolean YES YES NO NO NO YES YES YES +# object YES YES NO YES NO YES YES YES +# class YES YES NO YES NO YES YES YES +# +# userdefined YES YES NO NO YES YES YES YES +# +# tclObj + converterArg (alnum..xdigit) Attribute ... -type alnum +# object + converterArg (some class, e.g. ::C) Attribute ... -type ::C Attribute -type object -arg ::C +# class + converterArg (some metaclass, e.g. ::M) Attribute -type class -arg ::M +# +# +#::xotcl::Slot { +# {name "[namespace tail [::xotcl::self]]"} +# {methodname} +# {domain "[lindex [regexp -inline {^(.*)::slot::[^:]+$} [::xotcl::self]] 1]"} +# {defaultmethods {get assign}} +# {manager "[::xotcl::self]"} +# {multivalued false} +# {per-object false} +# {required false} +# default +# type +# } -- No instances +# +# ::xotcl::RelationSlot -superclass ::xotcl::Slot { +# {multivalued true} +# {type relation} +# {elementtype ::nx::Class} +# } -- sample instances: class superclass, mixin filter +# +# ::nx::Attribute -superclass ::xotcl::Slot { +# {value_check once} +# defaultcmd +# valuecmd +# valuechangedcmd +# arg +# } -- typical object parameters +# +# MethodParameterSlot -attributes {type required multivalued noarg arg} +# -- typical method parameters + + +####################################################### +# objectparameter +####################################################### +Test parameter count 10 +Test case objectparameter { + + Class create C -attributes {a {b:boolean} {c 1}} + C create c1 + + ? {C eval {:objectparameter}} \ + "-object-mixin:relation,slot=::nx::Class::slot::object-mixin -mixin:relation,arg=class-mixin,slot=::nx::Class::slot::mixin -superclass:relation,slot=::nx::Class::slot::superclass -object-filter:relation,slot=::nx::Class::slot::object-filter -filter:relation,arg=class-filter,slot=::nx::Class::slot::filter -class:relation,slot=::nx::Object::slot::class -attributes:method,optional -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" + + + + + ? {c1 eval {:objectparameter}} \ + "-a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" +} + +####################################################### +# reclass to Object, no need to do anything on caching +####################################################### +Test case reclass { + + Class create C -attributes {a {b:boolean} {c 1}} + C create c1 + + c1 class Object + ? {c1 eval :objectparameter} \ + "-mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" + + Class create D -superclass C -attributes {d:required} + D create d1 -d 100 + + ? {d1 eval :objectparameter} \ + "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" +} + +####################################################### +# Add mixin +####################################################### +Test case objparam-mixins { + + Class create C -attributes {a {b:boolean} {c 1}} + Class create D -superclass C -attributes {d:required} + D create d1 -d 100 + + Class create M -attributes {m1 m2 b} + Class create M2 -attributes {b2} + D mixin M + ? {d1 eval :objectparameter} \ + "-b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" \ + "mixin added" + M mixin M2 + ? {d1 eval :objectparameter} \ + "-b2:slot=::M2::slot::b2 -b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" \ + "transitive mixin added" + D mixin "" + #we should have again the old interface + + ? {d1 eval :objectparameter} \ + "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" + + C mixin M + ? {d1 eval :objectparameter} \ + "-b2:slot=::M2::slot::b2 -b:slot=::M::slot::b -m1:slot=::M::slot::m1 -m2:slot=::M::slot::m2 -d:required,slot=::D::slot::d -a:slot=::C::slot::a {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" \ + "mixin added" + C mixin "" + #we should have again the old interface + + ? {d1 eval :objectparameter} \ + "-d:required,slot=::D::slot::d -a:slot=::C::slot::a -b:boolean,slot=::C::slot::b {-c:slot=::C::slot::c 1} -mixin:relation,arg=object-mixin,slot=::nx::Object::slot::mixin -filter:relation,arg=object-filter,slot=::nx::Object::slot::filter -class:relation,slot=::nx::Object::slot::class -noinit:method,optional,noarg -volatile:method,optional,noarg __initcmd:initcmd,optional" +} + +####################################################### +# test passed arguments +####################################################### + +Test case passed-arguments { + + Class create C -attributes {a {b:boolean} {c 1}} + Class create D -superclass C -attributes {d:required} + + ? {catch {D create d1 -d 123}} 0 "create d1 with required argument given" + ? {catch {D create d1}} 1 "create d1 without required argument given" + #puts stderr current=[namespace current] + + ? {D create d1} "::d1 configure: required argument 'd' is missing" "check error msg" + + ? {D create d2 -d x -b a} \ + {expected boolean value but got "a" for parameter -b} \ + "create d2 without required argument given" + + D create d1 -d 1 + D public method foo {-b:boolean -r:required,int {-x:int aaa} {-object:object} {-class:class}} { + #if {[info exists x]} {puts stderr x=$x} + } + + ? {d1 foo} \ + "::d1 foo: required argument 'r' is missing" \ + "call method without a required argument" + + ? {d1 foo -r a} \ + {expected integer but got "a" for parameter -r} \ + "required argument is not integer" + + ? {d1 foo -r 1} \ + {expected integer but got "aaa" for parameter -x} \ + "default value is not of type integer" + + ? {d1 foo -r 1 -x 1 -object d1} \ + "" \ + "pass object" + + ? {d1 foo -r 1 -x 1 -object d11} \ + {expected object but got "d11" for parameter -object} \ + "pass non-existing object" + + ? {d1 foo -r 1 -x 1 -class D} \ + "" \ + "pass class" + + ? {d1 foo -r 1 -x 1 -class d1} \ + {expected class but got "d1" for parameter -class} \ + "pass object instead of class" + + ? {d1 foo -r 1 -x 1 -class D11} \ + {expected class but got "D11" for parameter -class} \ + "pass non-existing class" + + ? {D public method foo {a:relation} {}} \ + {Parameter option 'relation' not allowed} \ + "don't allow relation option as method parameter" + + ? {D public method foo {a:double} {return $a}} \ + {::nsf::classes::D::foo} \ + "allow 'string is XXXX' for argument checking" + ? {d1 foo 1} 1 "check int as double" + ? {d1 foo 1.1} 1.1 "check double as double" + ? {d1 foo 1.1a} {expected double but got "1.1a" for parameter a} "check non-double as double" + ? {D info method parameter foo} a:double +} + +####################################################### +# non required positional arguments +####################################################### +Test case non-reg-args { + + Class create D + D create d1 + + D public method foo {a b:optional c:optional} { + return "[info exists a]-[info exists b]-[info exists c]" + } + ? {d1 foo 1 2} "1-1-0" "omit optional argument" + ? {d1 foo 1} "1-0-0" "omit optional arguments" + + # non required positional arguments and args + D public method foo {a b:optional c:optional args} { + return "[info exists a]-[info exists b]-[info exists c]-[info exists args]" + } + ? {d1 foo 1 2} "1-1-0-1" "omit optional argument" + ? {d1 foo 1} "1-0-0-1" "omit optional arguments" +} + +####################################################### +# multivalued arguments +####################################################### +Test case multivalued { + + Class create D + D create d1 + Object create o + + D public method foo {m:integer,multivalued} { + return $m + } + ? {d1 foo ""} "" "emtpy list" + ? {d1 foo 1} "1" "single value" + ? {d1 foo {1 2}} "1 2" "multiple values" + ? {d1 foo {1 a 2}} \ + {invalid value in "1 a 2": expected integer but got "a" for parameter m} \ + "multiple values with wrong value" + + D public method foo {m:object,multivalued} { + return $m + } + ? {d1 foo ""} "" "emtpy list" + ? {d1 foo o} "o" "single value" + ? {d1 foo {o d1 x}} \ + {invalid value in "o d1 x": expected object but got "x" for parameter m} \ + "multiple values" + + Class create Foo -attributes { + {ints:integer,multivalued} + } + ? {Foo create foo -ints {1 2}} "::foo" + ? {Foo create foo -ints {1 a 2}} {invalid value in "1 a 2": expected integer but got "a" for parameter -ints} + + # make slot incremental + Foo::slot::ints eval { + set :incremental 1 + :optimize + } + + Foo create foo -ints {1 2} + ? {foo ints add 0} "0 1 2" + ? {foo ints add a} {expected integer but got "a" for parameter value} +} + +####################################################### +# subst default tests +####################################################### +Test case subst-default { + + Class create D { + :attribute {c 1} + :attribute {d 2} + + :create d1 + + :public method bar { + {-s:substdefault "[current]"} + {-literal "[current]"} + {-c:substdefault "[my c]"} + {-d:integer,substdefault "$d"} + } { + return $s-$literal-$c-$d + } + } + + ? {d1 bar -c 1} {::d1-[current]-1-2} "substdefault in method parameter" + + Class create Bar -superclass D -attributes { + {s "[current]"} + {literal "\\[current\\]"} + {c "[:info class]"} + {d "literal $d"} + {switch:switch} + } + Bar create bar1 + #puts stderr [bar1 objectparameter] + + ? {subst {[bar1 s]-[bar1 literal]-[bar1 c]-[bar1 d]-[bar1 switch]}} \ + {::bar1-[current]-::Bar-literal $d-0} \ + "substdefault and switch in object parameter 1" + + Bar create bar2 -switch + ? {subst {[bar2 s]-[bar2 literal]-[bar2 c]-[bar2 d]-[bar2 switch]}} \ + {::bar2-[current]-::Bar-literal $d-1} \ + "substdefault and switch in object parameter 2" + + # Observations: + # 1) syntax for "-attributes" and method parameter is quite different. + # it would be nice to be able to specify the objparameters in + # the same syntax as the method parameters. + # + # 1a) Especially specifying "-" in front of a -attributes or not might + # be confusing. + # + # 1b) Positional args for obj parameter and arguments for init + # might be confusing as well. Should we forget about + # passing arguments to init? + # + # 2) substdefault for '$' in -attributes defaults does not make much sense. + # deactivated for now; otherwise we would need "\\" + + D method bar { + {-s:substdefault "[current]"} + {-literal "[current]"} + {-c:substdefault "[my c]"} + {-d:integer,substdefault "$d"} + {-switch:switch} + {-optflag} + x + y:integer + {z 1} + } { + return $s-$literal-$c-$d + } + + ? {D info method args bar} {s literal c d switch optflag x y z} "all args" + ? {D info method parameter bar} \ + {{-s:substdefault "[current]"} {-literal "[current]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} -switch:switch -optflag x y:integer {z 1}} \ + "query method parameter" + + D public method foo {a b {-c 1} {-d} x {-end 100}} { + set result [list] + foreach v [[current class] info method args [current method]] { + lappend result $v [info exists $v] + } + return $result + } + ? {d1 foo 1 2 3} \ + "a 1 b 1 c 1 d 0 x 1 end 1" \ + "parse multiple groups of nonpos args" + + D public method foo {a b c {end 100}} { + set result [list] + foreach v [[current class] info method args [current method]] { + lappend result $v [info exists $v] + } + return $result + } + ? {d1 foo 1 2 3} \ + "a 1 b 1 c 1 end 1" \ + "query arguments with default, no paramdefs needed" + + ####################################################### + # Query method parameter + ####################################################### + + ? {D info method parameter foo} \ + "a b c {end 100}" \ + "query instparams with default, no paramdefs needed" + + ? {Class info method parameter method} \ + "name arguments body -precondition -postcondition" \ + "query instparams for scripted method 'method'" + + ? {Object info method parameter ::nsf::forward} \ + "object -per-object method -default -earlybinding -methodprefix -objscope -onerror -verbose target:optional args" \ + "query parameter for C-defined cmd 'nsf::forward'" + + Object require method autoname + ? {Object info method parameter autoname} \ + "-instance -reset name" \ + "query parameter for C-defined method 'autoname'" + + # TODO: how to query the params/instparams of info subcommands? + #? {::xotcl::objectInfo info params params} \ + # "xxx" \ + # "query instparams for info method 'params' method" +} + +####################################################### +# user defined parameter types +####################################################### +Test case user-types { + + Class create D -attributes d + D create d1 + + # create a userdefined type + ::nx::methodParameterSlot method type=mytype {name value args} { + if {$value < 1 || $value > 3} { + error "Value '$value' of parameter $name is not between 1 and 3" + } + } + + + D public method foo {a:mytype} { + return a=$a + } + d1 foo 1 + + ? {d1 foo 10} \ + "Value '10' of parameter a is not between 1 and 3" \ + "value not between 1 and 3" + + D public method foo {a:unknowntype} { + return $a + } + + ? {d1 foo 10} \ + "::nx::methodParameterSlot: unable to dispatch method 'type=unknowntype'" \ + "missing type checker" + + # create a userdefined type with a simple argument + ::nx::methodParameterSlot method type=in {name value arg} { + if {$value ni [split $arg |]} { + error "Value '$value' of parameter $name not in permissible values $arg" + } + return $value + } + + D public method foo {a:in,arg=a|b|c} { + return a=$a + } + + ? {d1 foo a} "a=a" + ? {d1 foo 10} \ + "Value '10' of parameter a not in permissible values a|b|c" \ + "invalid value" + + D public method foo {a:in,arg=a|b|c b:in,arg=good|bad {-c:in,arg=a|b a}} { + return a=$a,b=$b,c=$c + } + + ? {d1 foo a good -c b} "a=a,b=good,c=b" + ? {d1 foo a good} "a=a,b=good,c=a" + ? {d1 foo b "very good"} \ + "Value 'very good' of parameter b not in permissible values good|bad" \ + "invalid value (not included)" + + ::nx::methodParameterSlot method type=range {name value arg} { + foreach {min max} [split $arg -] break + if {$value < $min || $value > $max} { + error "Value '$value' of parameter $name not between $min and $max" + } + return $value + } + + D public method foo {a:range,arg=1-3 {-b:range,arg=2-6 3} c:range,arg=5-10} { + return a=$a,b=$b,c=$c + } + + ? {d1 foo 2 -b 4 9} "a=2,b=4,c=9" + ? {d1 foo 2 10} "a=2,b=3,c=10" + ? {d1 foo 2 11} \ + "Value '11' of parameter c not between 5 and 10" \ + "invalid value" + + # define type twice + ? {D public method foo {a:int,range,arg=1-3} {return a=$a}} \ + "Refuse to redefine parameter converter to use type=range" \ + "invalid value" + + # + # handling of arg with spaces/arg as list + # + ::nx::methodParameterSlot public method type=list {name value arg} { + #puts $value/$arg + return $value + } + + # handling spaces in "arg" is not not particular nice + D public method foo {{"-a:list,arg=2 6" 3} {"b:list,arg=5 10"}} { + return a=$a,b=$b + } + ? {d1 foo -a 2 10} "a=2,b=10" + +} +####################################################### +# testing object types in method parameters +####################################################### +Test case mp-object-types { + + Class create C + Class create D -superclass C -attributes d + + Class create M + D create d1 -d 1 + C create c1 -mixin M + Object create o + + D public method foo-base {x:baseclass} {return $x} + D public method foo-class {x:class} {return $x} + D public method foo-object {x:object} {return $x} + D public method foo-meta {x:metaclass} {return $x} + D public method foo-type {x:object,type=::C} {return $x} + + ? {D info method parameter foo-base} "x:baseclass" + ? {D info method parameter foo-type} "x:object,type=::C" + + ? {d1 foo-base ::nx::Object} "::nx::Object" + ? {d1 foo-base C} \ + {expected baseclass but got "C" for parameter x} \ + "not a base class" + + ? {d1 foo-class D} "D" + ? {d1 foo-class xxx} \ + {expected class but got "xxx" for parameter x} \ + "not a class" + ? {d1 foo-class o} \ + {expected class but got "o" for parameter x} \ + "not a class" + + ? {d1 foo-meta ::nx::Class} "::nx::Class" + ? {d1 foo-meta ::nx::Object} \ + {expected metaclass but got "::nx::Object" for parameter x} \ + "not a base class" + + ? {d1 foo-object o} "o" + ? {d1 foo-object xxx} \ + {expected object but got "xxx" for parameter x} \ + "not an object" + + ? {d1 foo-type d1} "d1" + ? {d1 foo-type c1} "c1" + ? {d1 foo-type o} \ + {expected object of type ::C but got "o" for parameter x} \ + "o not of type ::C" +} + +####################################################### +# substdefault +####################################################### +Test case substdefault { + + Class create S -attributes {{x 1} {y b} {z {1 2 3}}} + S create s1 { + :public method foo {{y:substdefault ${:x}}} { + return $y + } + :public method bar {{y:integer,substdefault ${:x}}} { + return $y + } + :public method baz {{x:integer,substdefault ${:y}}} { + return $x + } + :public method boz {{x:integer,multivalued,substdefault ${:z}}} { + return $x + } + } + ? {s1 foo} 1 + ? {s1 foo 2} 2 + + ? {S method foo {a:substdefault} {return 1}} \ + {parameter option substdefault specified for parameter "a" without default value} + + ? {s1 bar} 1 + ? {s1 bar 3} 3 + ? {s1 bar a} {expected integer but got "a" for parameter y} + + ? {s1 baz} {expected integer but got "b" for parameter x} + ? {s1 baz 20} 20 + s1 y 100 + ? {s1 baz} 100 + ? {s1 baz 101} 101 + + ? {s1 boz} {1 2 3} + s1 z {1 x 100} + ? {s1 boz} {invalid value in "1 x 100": expected integer but got "x" for parameter x} + ? {s1 boz {100 200}} {100 200} + + set ::aaa 100 + ? {s1 public method foo {{a:substdefault $::aaa}} {return $a}} ::s1::foo + ? {s1 foo} 100 + unset ::aaa + ? {s1 foo} {can't read "::aaa": no such variable} + + ? {s1 public method foo {{a:substdefault $aaa}} {return $a}} ::s1::foo + ? {s1 foo} {can't read "aaa": no such variable} + + ? {s1 public method foo {{a:substdefault [current]}} {return $a}} ::s1::foo + ? {s1 foo} ::s1 +} + +####################################################### +# testing substdefault for object parameters +####################################################### +Test case substdefault-objparam { + + Class create Bar { + + # simple, implicit substdefault + :attribute {s0 "[current]"} + + # explicit substdefault + :attribute {s1:substdefault "[current]"} + + # unneeded double substdefault + :attribute {s2:substdefault,substdefault "[current]"} + + # substdefault with incremental + :attribute {s3:substdefault "[current]"} { + # Bypassing the Optimizer helps after applying the patch (solving step 1) + set :incremental 1 + } + } + + Bar create ::b + ? {b s0} "::b" + ? {b s1} "::b" + ? {b s2} "::b" + ? {b s3} "::b" +} + +####################################################### +# testing object types in object parameters +####################################################### +Test case op-object-types { + + Class create C + Class create D -superclass C -attributes d + + Class create MC -superclass Class + MC create MC1 + Class create M + D create d1 -d 1 + C create c1 -mixin M + Object create o + + Class create ParamTest -attributes { + o:object + c:class + c1:class,type=::MC + d:object,type=::C + d1:object,type=C + m:metaclass + b:baseclass + u:upper + us:upper,multivalued + {x:object,multivalued {o}} + } + + # TODO: we have no good interface for querying the slot notation for parameters + proc ::parameterFromSlot {class objectparameter} { + set slot ${class}::slot::$objectparameter + array set "" [$slot toParameterSyntax $objectparameter] + return $(oparam) + } + + ? {::parameterFromSlot ParamTest o} "o:object,slot=::ParamTest::slot::o" + ? {::parameterFromSlot ParamTest c} "c:class,slot=::ParamTest::slot::c" + ? {::parameterFromSlot ParamTest c1} "c1:class,type=::MC,slot=::ParamTest::slot::c1" + ? {::parameterFromSlot ParamTest d} "d:object,type=::C,slot=::ParamTest::slot::d" + ? {::parameterFromSlot ParamTest d1} "d1:object,type=::C,slot=::ParamTest::slot::d1" + #? {::parameterFromSlot ParamTest mix} "mix:hasmixin,arg=M,slot=::ParamTest::slot::mix" + ? {::parameterFromSlot ParamTest x} "x:object,multivalued,slot=::ParamTest::slot::x o" + ? {::parameterFromSlot ParamTest u} "u:upper,slot=::ParamTest::slot::u" + ? {::parameterFromSlot ParamTest us} "us:upper,multivalued,slot=::ParamTest::slot::us" + + ? {ParamTest create p -o o} ::p + ? {ParamTest create p -o xxx} \ + {expected object but got "xxx" for parameter -o} \ + "not an object" + + ? {ParamTest create p -c C} ::p "class" + ? {ParamTest create p -c o} \ + {expected class but got "o" for parameter -c} \ + "not a class" + + ? {ParamTest create p -c1 MC1} ::p "instance of meta-class MC" + ? {ParamTest create p -c1 C} \ + {expected class of type ::MC but got "C" for parameter -c1} \ + "not an instance of meta-class MC" + + ? {ParamTest create p -d d1} ::p + ? {ParamTest create p -d1 d1} ::p + ? {ParamTest create p -d c1} ::p + ? {ParamTest create p -d o} \ + {expected object of type ::C but got "o" for parameter -d} \ + "o not of type ::C" + + #? {ParamTest create p -mix c1} ::p + #? {ParamTest create p -mix o} \ + {expected object with mixin M but got "o" for parameter mix} \ + "does not have mixin M" + + ? {ParamTest create p -u A} ::p + ? {ParamTest create p -u c1} {expected upper but got "c1" for parameter -u} + ? {ParamTest create p -us {A B c}} \ + {invalid value in "A B c": expected upper but got "c" for parameter -us} + ParamTest::slot::us eval { + set :incremental 1 + :optimize + } + ? {ParamTest create p -us {A B}} ::p + ? {p us add C end} "A B C" + + ? {p o o} \ + "o" \ + "value is an object" + + ? {p o xxx} \ + {expected object but got "xxx" for parameter o} \ + "value is not an object" + + #ParamTest slots { + # ::nx::Attribute create os -type object -multivalued true + #} + ParamTest eval { + :attribute os { + :type object + :multivalued true + } + } + + ? {p os o} \ + "o" \ + "value is a list of objects (1 element)" + ? {p os {o c1 d1}} \ + "o c1 d1" \ + "value is a list of objects (multiple elements)" + + ? {p os {o xxx d1}} \ + {invalid value in "o xxx d1": expected object but got "xxx" for parameter os} \ + "list with invalid object" +} + +####################################################### +# application specific multivalued converter +####################################################### +Test case multivalued-app-converter { + + ::nx::methodParameterSlot public method type=sex {name value args} { + #puts stderr "[current] slot specific converter" + switch -glob $value { + m* {return m} + f* {return f} + default {error "expected sex but got $value"} + } + } + Class create C { + :public method foo {s:sex,multivalued,convert} {return $s} + :public method bar {s:sex,multivalued} {return $s} + } + C create c1 + ? {c1 foo {male female mann frau}} "m f m f" + ? {c1 bar {male female mann frau}} "male female mann frau" + + Object create tmpObj + tmpObj method type=mType {name value arg:optional} { + if {$value} { + error "expected false but got $value" + } + # Note that this converter does NOT return a value; it converts all + # values into emtpy strings. + } + ? {::nsf::is -complain mType,slot=::tmpObj,multivalued {1 0}} \ + {invalid value in "1 0": expected false but got 1} \ + "fail on first value" + ? {::nsf::is -complain mType,slot=::tmpObj,multivalued {0 0 0}} 1 "all pass" + ? {::nsf::is -complain mType,slot=::tmpObj,multivalued {0 1}} \ + {invalid value in "0 1": expected false but got 1} \ + "fail o last value" +} +####################################################### +# application specific multivalued converter +####################################################### +Test case shadowing-app-converter { + + Object create mySlot { + :public method type=integer {name value arg:optional} { + return [expr {$value + 1}] + } + } + Object create o { + :public method foo {x:integer,slot=::mySlot,convert} { + return $x + } + } + + ? {::nsf::is -complain integer,slot=::mySlot 1} 1 + ? {o foo 3} 4 +} + + +####################################################### +# allow empty values +####################################################### +Test case allow-empty { + + Object create o1 + Object create o2 + Object create o3 + + Object create o { + :public method foo {x:integer,allowempty y:integer os:object,multivalued,allowempty} { + return $x + } + } + + ? {o foo 1 2 {o1 o2}} 1 "all values specified" + ? {o foo "" 2 {o1 o2}} "" "first is empty" + ? {o foo 1 "" {o1 o2}} {expected integer but got "" for parameter y} "second is empty" + ? {o foo 1 2 {}} 1 "empty list, does not require allowempty" + ? {o foo 1 2 {o1 "" o2}} 1 "list contains empty value" + + ? {o info method parameter foo} "x:integer,allowempty y:integer os:object,multivalued,allowempty" + + o public method foo {x:integer,allowempty y:integer os:object,multivalued} {return $x} + ? {o foo 1 2 {o1 "" o2}} {invalid value in "o1 "" o2": expected object but got "" for parameter os} \ + "list contains empty value" + +} +####################################################### +# slot specific converter +####################################################### +Test case slot-specfic-converter { + + Class create Person { + :attribute sex { + :type "sex" + :convert true + :method type=sex {name value} { + #puts stderr "[self] slot specific converter" + switch -glob $value { + m* {return m} + f* {return f} + default {error "expected sex but got $value"} + } + } + } + } + + Person create p1 -sex male + ? {p1 sex} m + Person public method foo {s:sex,slot=::Person::slot::sex,convert} {return $s} + ? {p1 foo male} m + ? {p1 sex male} m +} + +####################################################### +# test for setters with parameters +####################################################### +Test case setters { + Object create o + Class create C + + ? {::nsf::setter o a} "::o::a" + ? {::nsf::setter C c} "::nsf::classes::C::c" + ? {o info method definition a} "::o public setter a" + ? {o info method parameter a} "a" + ? {o info method args a} "a" + ? {C info method definition c} "::C public setter c" + ? {o a 1} "1" + + ? {::nsf::setter o a:integer} "::o::a" + ? {::nsf::setter o ints:integer,multivalued} "::o::ints" + ? {::nsf::setter o o:object} "::o::o" + + ? {o info method handle ints} "::o::ints" + ? {o info method definition ints} "::o public setter ints:integer,multivalued" + ? {o info method parameter ints} "ints:integer,multivalued" + ? {o info method args ints} "ints" + + ? {o info method handle o} "::o::o" + ? {o info method definition o} "::o public setter o:object" + ? {o info method parameter o} "o:object" + ? {o info method args o} "o" + + ? {o a 2} 2 + ? {o a hugo} {expected integer but got "hugo" for parameter a} + + ? {o ints {10 100 1000}} {10 100 1000} + ? {o ints hugo} {invalid value in "hugo": expected integer but got "hugo" for parameter ints} + ? {o o o} o + ? {::nsf::setter o {d default}} {parameter "d" is not allowed to have default "default"} + ? {::nsf::setter o -x} {method name "-x" must not start with a dash} +} + + + +####################################################### +# test for slot-optimizer +####################################################### +Test parameter count 1000 +Test case slot-optimizer { + + Class create C -attributes {a b:integer c:integer,multivalued} + + C create c1 + ? {c1 a 1} 1 + ? {c1 b 1} 1 + ? {c1 c 1} 1 + + # before: 1st case: setter, 2&3: forward + #slot-optimizer.001: 1.50 mms, c1 a 1 + #slot-optimizer.002: 3.30 mms, c1 b 1 + #slot-optimizer.003: 3.40 mms, c1 c 1 + # + # after: 1st, 2nd, 3rd case: setter + #slot-optimizer.001: 1.50 mms, c1 a 1 + #slot-optimizer.002: 1.50 mms, c1 b 1 + #slot-optimizer.003: 1.60 mms, c1 c 1 +} + +Test parameter count 10 +Test case slot-nosetter { + Class create C -attributes {a b:integer,nosetter {c:nosetter ""}} + + ? {C create c1 -a 1 -b 2} ::c1 + ? {c1 info vars} "a b c" + ? {c1 a 100} 100 + ? {c1 b 101} {::c1: unable to dispatch method 'b'} + ? {c1 c 102} {::c1: unable to dispatch method 'c'} +} + +Test parameter count 1000 +Test case check-arguments { + + Class create Foo { + :public method noarg {} {return ""} + :public method onearg {x} {return $x} + :public method intarg {x:integer} {return $x} + :public method intsarg {x:integer,multivalued} {return $x} + :public method boolarg {x:boolean} {return $x} + :public method classarg {x:class} {return $x} + :public method upperarg {x:upper} {return $x} + :public method metaclassarg {x:metaclass} {return $x} + :create f1 + } + + ? {f1 noarg} "" + ? {f1 onearg 1} 1 + # built-in checker + ? {f1 intarg 1} 1 + ? {f1 intarg a} {expected integer but got "a" for parameter x} + ? {f1 intsarg {10 11 12}} {10 11 12} + ? {f1 intsarg {10 11 1a2}} {invalid value in "10 11 1a2": expected integer but got "1a2" for parameter x} + ? {f1 boolarg 1} 1 + ? {f1 boolarg a} {expected boolean value but got "a" for parameter x} + ? {f1 classarg ::Foo} ::Foo + ? {f1 classarg f1} {expected class but got "f1" for parameter x} + # tcl checker + ? {f1 upperarg ABC} ABC + ? {f1 upperarg abc} {expected upper but got "abc" for parameter x} + # scripted checker + ? {f1 metaclassarg ::nx::Class} ::nx::Class + ? {f1 metaclassarg ::Foo} {expected metaclass but got "::Foo" for parameter x} +} + +Test case slot-traces { + ::nx::Object create o { + :attribute a {set :defaultcmd { set _ 4 } } + :attribute b {set :valuecmd { set _ 44 } } + :attribute c {set :valuechangedcmd { ::nsf::setvar $obj $var 999 }} + } + + ? {o a} 4 + ? {o b} 44 + ? {o c 5} 999 + + o copy o2 + + ? {o a} 4 + ? {o b} 44 + ? {o c 5} 999 + + ::nx::Class create C { + :attribute a {set :defaultcmd { set _ 4 } } + :attribute b {set :valuecmd { set _ 44 } } + :attribute c {set :valuechangedcmd { ::nsf::setvar $obj $var 999 }} + :create c1 + } + + ? {c1 a} 4 + ? {c1 b} 44 + ? {c1 c 5} 999 + + c1 copy c2 + + ? {c2 a} 4 + ? {c2 b} 44 + ? {c2 c 5} 999 + + C copy D + D create d1 + + ? {d1 a} 4 + ? {d1 b} 44 + ? {d1 c 5} 999 +} + +::nsf::configure checkarguments off +Test case check-arguments-nocheck { + + Class create Foo { + :public method noarg {} {return ""} + :public method onearg {x} {return $x} + :public method intarg {x:integer} {return $x} + :public method intsarg {x:integer,multivalued} {return $x} + :public method boolarg {x:boolean} {return $x} + :public method classarg {x:class} {return $x} + :public method upperarg {x:upper} {return $x} + :public method metaclassarg {x:metaclass} {return $x} + :create f1 + } + + ? {f1 noarg} "" + ? {f1 onearg 1} 1 + # built-in checker + ? {f1 intarg 1} 1 + ? {f1 intarg a} a + ? {f1 intsarg {10 11 12}} {10 11 12} + ? {f1 intsarg {10 11 1a2}} {10 11 1a2} + ? {f1 boolarg 1} 1 + ? {f1 boolarg a} a + ? {f1 classarg ::Foo} ::Foo + ? {f1 classarg f1} f1 + # tcl checker + ? {f1 upperarg ABC} ABC + ? {f1 upperarg abc} abc + # scripted checker + ? {f1 metaclassarg ::nx::Class} ::nx::Class + ? {f1 metaclassarg ::Foo} ::Foo +} + +## TODO regression test for type checking, parameter options (initcmd, +## substdefault, combinations with defaults, ...), etc. + +Test parameter count 100 + +Test case checktype { + nx::Object create o { + :public method f01 {} {::nsf::dispatch o ::nsf::methods::object::info::hastype ::nx::Object} + :public method f02 {} {::nsf::dispatch o ::nsf::methods::object::info::hastype nx::Object} + :public method f03 {} {::nsf::dispatch o ::nsf::methods::object::info::hastype Object} + + :public method f11 {} {::nsf::is object,type=::nx::Object o} + :public method f12 {} {::nsf::is object,type=nx::Object o} + :public method f13 {} {::nsf::is object,type=Object o} + } + + ? {o f01} 1 + ? {o f02} 1 + ? {o f03} 1 + + ? {o f11} 1 + ? {o f12} 1 + ? {o f13} 1 +} + +# +# testing namespace resolution in type checkers +# +namespace eval foo { + nx::Class create C { + :create c1 + :public method f21 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype Object} + :public method f22 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype C} + :public method f31 {} {::nsf::is object,type=Object c1} + :public method f32 {} {::nsf::is object,type=C c1} + } + + nx::Object create o { + :public method f01 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype ::nx::Object} + :public method f02 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype nx::Object} + :public method f03 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype Object} + :public method f04 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype foo::C} + :public method f05 {} {::nsf::dispatch c1 ::nsf::methods::object::info::hastype C} + + :public method f11 {} {::nsf::is object,type=::nx::Object c1} + :public method f12 {} {::nsf::is object,type=nx::Object c1} + :public method f13 {} {::nsf::is object,type=Object c1} + :public method f14 {} {::nsf::is object,type=foo::C c1} + :public method f15 {} {::nsf::is object,type=C c1} + } + + ? {o f01} 1 + ? {o f02} 1 + ? {o f03} 1 + ? {o f04} 1 + ? {o f05} 1 + + ? {o f11} 1 + ? {o f12} 1 + ? {o f13} 1 + ? {o f14} 1 + ? {o f15} 1 + + ? {c1 f21} 1 + ? {c1 f22} 1 + ? {c1 f31} 1 + ? {c1 f32} 1 +} + +Test case check-arguments { + + Class create Foo { + :method noarg {} {return ""} + :method onearg {-x} {return $x} + :method intarg {-x:integer} {return $x} + :method intsarg {-x:integer,multivalued} {return $x} + :method boolarg {-x:boolean} {return $x} + :method classarg {-x:class} {return $x} + :method upperarg {-x:upper} {return $x} + :method metaclassarg {-x:metaclass} {return $x} + } + + ? {Foo info method parametersyntax noarg} "" + ? {Foo info method parametersyntax onearg} "?-x value?" + ? {Foo info method parametersyntax intarg} "?-x integer?" + ? {Foo info method parametersyntax intsarg} "?-x integer ...?" + ? {Foo info method parametersyntax boolarg} "?-x boolean?" + ? {Foo info method parametersyntax classarg} "?-x class?" + ? {Foo info method parametersyntax upperarg} "?-x upper?" + ? {Foo info method parametersyntax metaclassarg} "?-x metaclass?" + + # return enumeration type + ? {nx::Class info method parametersyntax "info mixinof"} \ + "?-closure? ?-scope all|class|object? ?pattern?" +} \ No newline at end of file Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/protected.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/protected.test =================================================================== diff -u --- tests/protected.test (revision 0) +++ tests/protected.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,102 @@ +# -*- Tcl *-* +package require nx +package require nx::test +namespace import ::nx::* + +Test parameter count 1 + +Class create C { + :public alias SET ::set + :public method foo {} {return [current method]} + :public method bar {} {return [current method]} + :public method bar-foo {} { + c1 foo + } + :public method bar-SET {} { + c1 SET x 1 + } +} + +C create c1 +C create c2 + +? {c1 SET x 1} {1} +? {c1 foo} {foo} +? {c1 bar-SET} {1} +? {c1 bar-foo} {foo} + +::nsf::methodproperty C SET call-protected true +? {catch {c1 SET x 1} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {::nsf::dispatch c1 SET x 2} {2} "dispatch of protected methods works" +? {c1 foo} {foo} +? {c1 bar} {bar} +? {c1 bar-SET} {1} +? {c1 bar-foo} {foo} +? {catch {c2 bar-SET} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {c2 bar-foo} {foo} + +::nsf::methodproperty C foo call-protected true +? {catch {c1 SET x 1} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {::nsf::dispatch c1 SET x 2} {2} "dispatch of protected methods works" +? {c1 bar} {bar} "other method work" +? {catch {c1 foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} +? {c1 bar-SET} {1} "internal call of protected C implementend method" +? {c1 bar-foo} {foo} "internal call of protected Tcl implemented method" +? {catch {c2 bar-SET} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {catch {c2 bar-foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} + +# unset protected +? {::nsf::methodproperty C SET call-protected} 1 + ::nsf::methodproperty C SET call-protected false +? {::nsf::methodproperty C SET call-protected} 0 +? {::nsf::methodproperty C foo call-protected} 1 + ::nsf::methodproperty C foo call-protected false +? {::nsf::methodproperty C foo call-protected} 0 + +? {c1 SET x 3} 3 +? {::nsf::dispatch c1 SET x 2} {2} +? {c1 foo} {foo} +? {c1 bar} {bar} +? {c1 bar-SET} {1} +? {c1 bar-foo} {foo} +? {c2 bar-SET} 1 +? {c2 bar-foo} {foo} + +# define a protected method +C protected method foo {} {return [current method]} +? {::nsf::methodproperty C SET call-protected} 0 +? {c1 SET x 3} 3 +? {::nsf::dispatch c1 SET x 4} {4} +? {catch {c1 foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} +? {c1 bar} {bar} +? {c1 bar-SET} {1} +? {c1 bar-foo} foo +? {c2 bar-SET} 1 +? {catch {c2 bar-foo} errorMsg; set errorMsg} {::c1: unable to dispatch method 'foo'} + +? {::nsf::methodproperty C SET redefine-protected true} 1 +? {catch {C method SET {a b c} {...}} errorMsg; set errorMsg} \ + {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} +? {::nsf::methodproperty C foo redefine-protected true} 1 +? {catch {C method foo {a b c} {...}} errorMsg; set errorMsg} \ + {Method 'foo' of ::C can not be overwritten. Derive e.g. a sub-class!} +# check a predefined protection +? {catch {::nx::Class method dealloc {a b c} {...}} errorMsg; set errorMsg} \ + {Method 'dealloc' of ::nx::Class can not be overwritten. Derive e.g. a sub-class!} +# try to redefined via alias +? {catch {::nsf::alias Class dealloc ::set} errorMsg; set errorMsg} \ + {Method 'dealloc' of ::nx::Class can not be overwritten. Derive e.g. a sub-class!} +# try to redefine via forward +? {catch {C forward SET ::set} errorMsg; set errorMsg} \ + {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} +# try to redefine via setter +? {catch {C setter SET} errorMsg; set errorMsg} \ + {Method 'SET' of ::C can not be overwritten. Derive e.g. a sub-class!} + +# overwrite-protect object specific method +Object create o +o method foo {} {return 13} +::nsf::methodproperty o foo redefine-protected true +? {catch {o method foo {} {return 14}} errorMsg; set errorMsg} \ + {Method 'foo' of ::o can not be overwritten. Derive e.g. a sub-class!} + Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/returns.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/returns.test =================================================================== diff -u --- tests/returns.test (revision 0) +++ tests/returns.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,292 @@ +# -*- Tcl *-* +package require nx +::nx::configure defaultMethodCallProtection false +package require nx::test + +# +# The same tests are in this test suite, once with and once without +# checking +# +# Make sure, checking is turned on +# +::nsf::configure checkresult true + +Test parameter count 10000 +Test case int-returns { + nx::Class create C { + # scripted method without paramdefs + :method bar-ok1 {a b} {return 1} + :method bar-ok2 {a b} {return $a} + # scripted method with paramdefs + :method bar-nok {a b:integer} {return a} + # alias to tcl-cmd (no param defs) + :alias incr -frame object ::incr + :alias lappend -frame object ::lappend + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns integer + ::nsf::methodproperty C bar-ok2 returns integer + ::nsf::methodproperty C bar-nok returns integer + ::nsf::methodproperty C incr returns integer + ::nsf::methodproperty C lappend returns integer + + ? {c1 bar-ok1 1 2} 1 + ? {c1 bar-ok2 1 2} 1 + ? {c1 bar-nok 1 2} {expected integer but got "a" for parameter return-value} + + ? {c1 incr x} 1 + ? {c1 incr x} 10002 + + ? {c1 lappend l e1} {expected integer but got "e1" for parameter return-value} + + # query the returns value + ? {::nsf::methodproperty C lappend returns} integer + + # reset it to emtpy + ? {::nsf::methodproperty C lappend returns ""} "" + ? {::nsf::methodproperty C bar-ok1 returns ""} "" + ? {::nsf::methodproperty C bar-ok2 returns ""} "" + ? {::nsf::methodproperty C bar-nok returns ""} "" + + # no checking + ? {c1 bar-ok1 1 2} 1 + ? {c1 bar-ok2 1 2} 1 + ? {c1 bar-nok 1 2} a + ? {c1 lappend l e2} "e1 e2" + + # query returns "", if there is no returns checking + ? {::nsf::methodproperty C lappend returns} "" + ? {::nsf::methodproperty ::nx::Object method returns} "" + +} + +Test parameter count 10 +Test case app-specific-returns { + + ::nx::methodParameterSlot method type=range {name value arg} { + foreach {min max} [split $arg -] break + if {$value < $min || $value > $max} { + error "Value '$value' of parameter $name not between $min and $max" + } + return $value + } + + nx::Class create C { + :method bar-ok1 {a b} {return 1} + :method bar-ok2 {a b} {return $a} + :method bar-nok {a b:integer} {return a} + :alias incr -frame object ::incr + :alias lappend -frame object ::lappend + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns range,arg=1-3 + ::nsf::methodproperty C bar-ok2 returns range,arg=1-3 + ::nsf::methodproperty C bar-nok returns range,arg=1-3 + ::nsf::methodproperty C incr returns range,arg=1-30 + ::nsf::methodproperty C lappend returns range,arg=1-30 + + ? {c1 bar-ok1 1 2} 1 + ? {c1 bar-ok2 1 2} 1 + ? {c1 bar-nok 1 2} {Value 'a' of parameter return-value not between 1 and 3} + + ? {c1 incr x} 1 + ? {c1 incr x} 12 + + ? {c1 lappend l e1} {Value 'e1' of parameter return-value not between 1 and 30} +} + +Test parameter count 1000 +Test case converting-returns { + + ::nx::methodParameterSlot method type=sex {name value args} { + #puts stderr "[current] slot specific converter" + switch -glob $value { + m* {return m} + f* {return f} + default {error "expected sex but got $value"} + } + } + + nx::Class create C { + :method bar-ok1 {a b} {return male} + :method bar-ok2 {a b} {return $a} + :method bar-nok {a b:integer} {return $b} + :alias set -frame object ::set + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns sex + ::nsf::methodproperty C bar-ok2 returns sex + ::nsf::methodproperty C bar-nok returns sex + ::nsf::methodproperty C set returns sex + + ? {c1 bar-ok1 1 2} male + ? {c1 bar-ok2 female 2} female + ? {c1 bar-nok 1 6} {expected sex but got 6} + + ? {c1 set x male} male + ? {c1 eval {set :x}} male + ? {c1 set x} male + + ? {c1 set x hugo} {expected sex but got hugo} + + ::nsf::methodproperty C bar-ok1 returns sex,convert + ::nsf::methodproperty C bar-ok2 returns sex,convert + ::nsf::methodproperty C bar-nok returns sex,convert + ::nsf::methodproperty C set returns sex,convert + + ? {c1 bar-ok1 1 2} m + ? {c1 bar-ok2 female 2} f + ? {c1 bar-nok 1 6} {expected sex but got 6} + + ? {c1 set x male} m + ? {c1 eval {set :x}} male + ? {c1 set x} m + + ? {c1 set x hugo} {expected sex but got hugo} +} + +# +# turn off result checking +# +::nsf::configure checkresults false + +Test parameter count 1000 +Test case int-returns-nocheck { + nx::Class create C { + # scripted method without paramdefs + :method bar-ok1 {a b} {return 1} + :method bar-ok2 {a b} {return $a} + # scripted method with paramdefs + :method bar-nok {a b:integer} {return a} + # alias to tcl-cmd (no param defs) + :alias incr -frame object ::incr + :alias lappend -frame object ::lappend + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns integer + ::nsf::methodproperty C bar-ok2 returns integer + ::nsf::methodproperty C bar-nok returns integer + ::nsf::methodproperty C incr returns integer + ::nsf::methodproperty C lappend returns integer + + ? {c1 bar-ok1 1 2} 1 + ? {c1 bar-ok2 1 2} 1 + ? {c1 bar-nok 1 2} a + + ? {c1 incr x} 1 + ? {c1 incr x} 1002 + + ? {c1 lappend l e1} e1 + + # query the returns value + ? {::nsf::methodproperty C lappend returns} integer + + # reset it to emtpy + ? {::nsf::methodproperty C lappend returns ""} "" + + c1 eval {set :l e1} + # no checking on lappend + ? {c1 lappend l e2} "e1 e2" + + # query returns "", if there is no returns checking + ? {::nsf::methodproperty C lappend returns} "" + ? {::nsf::methodproperty ::nx::Object method returns} "" + +} + +Test parameter count 10 +Test case app-specific-returns-nocheck { + + ::nx::methodParameterSlot method type=range {name value arg} { + foreach {min max} [split $arg -] break + if {$value < $min || $value > $max} { + error "Value '$value' of parameter $name not between $min and $max" + } + return $value + } + + nx::Class create C { + :method bar-ok1 {a b} {return 1} + :method bar-ok2 {a b} {return $a} + :method bar-nok {a b:integer} {return a} + :alias incr -frame object ::incr + :alias lappend -frame object ::lappend + :create c1 + } + + ::nsf::methodproperty C bar-ok1 returns range,arg=1-3 + ::nsf::methodproperty C bar-ok2 returns range,arg=1-3 + ::nsf::methodproperty C bar-nok returns range,arg=1-3 + ::nsf::methodproperty C incr returns range,arg=1-30 + ::nsf::methodproperty C lappend returns range,arg=1-30 + + ? {c1 bar-ok1 1 2} 1 + ? {c1 bar-ok2 1 2} 1 + ? {c1 bar-nok 1 2} a + + ? {c1 incr x} 1 + ? {c1 incr x} 12 + + ? {c1 lappend l e1} e1 +} + +Test parameter count 1000 +Test case converting-returns-nocheck { + + ::nx::methodParameterSlot method type=sex {name value args} { + #puts stderr "[current] slot specific converter" + switch -glob $value { + m* {return m} + f* {return f} + default {error "expected sex but got $value"} + } + } + + nx::Class create C { + :method bar-ok1 {a b} {return male} + :method bar-ok2 {a b} {return $a} + :method bar-nok {a b:integer} {return $b} + :alias set -frame object ::set + :create c1 + } + + # + # turn off checker + # + ::nsf::methodproperty C bar-ok1 returns sex + ::nsf::methodproperty C bar-ok2 returns sex + ::nsf::methodproperty C bar-nok returns sex + ::nsf::methodproperty C set returns sex + + ? {c1 bar-ok1 1 2} male + ? {c1 bar-ok2 female 2} female + ? {c1 bar-nok 1 6} 6 + + ? {c1 set x male} male + ? {c1 eval {set :x}} male + ? {c1 set x} male + + ? {c1 set x hugo} hugo + + # + # don't turn off converter + # + ::nsf::methodproperty C bar-ok1 returns sex,convert + ::nsf::methodproperty C bar-ok2 returns sex,convert + ::nsf::methodproperty C bar-nok returns sex,convert + ::nsf::methodproperty C set returns sex,convert + + ? {c1 bar-ok1 1 2} m + ? {c1 bar-ok2 female 2} f + ? {c1 bar-nok 1 6} {expected sex but got 6} + + ? {c1 set x male} m + ? {c1 eval {set :x}} male + ? {c1 set x} m + + ? {c1 set x hugo} {expected sex but got hugo} +} Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/submethods.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/submethods.test =================================================================== diff -u --- tests/submethods.test (revision 0) +++ tests/submethods.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,295 @@ +# -*- Tcl *-* +package req nx +namespace import ::nx::* +::nx::configure defaultMethodCallProtection false +package require nx::test + +Test case submethods { + #Object method unknown {} {} + Object create o1 + ? {o1 foo} "::o1: unable to dispatch method 'foo'" + + # + # test subcmd "tricky" names + # - names called on ensemble objects from C (defaultmethod, unknown) + # - names equal to helper methods of the ensemble object + # + Object create o { + :method "string length" x {return [current method]} + :method "string tolower" x {return [current method]} + :method "string info" x {return [current method]} + :method "foo a x" {} {return [current method]} + :method "foo a y" {} {return [current method]} + :method "foo a subcmdName" {} {return [current method]} + :method "foo a defaultmethod" {} {return [current method]} + :method "foo a unknown" args {return [current method]} + :method "foo b" {} {return [current method]} + } + Class create Foo { + :method "bar m1" {a:integer -flag} {;} + :method "bar m2" {x:integer -y:boolean} {;} + :method "baz a m1" {x:integer -y:boolean} {return m1} + :method "baz a m2" {x:integer -y:boolean} {;} + :method "baz b" {} {;} + } + + ? {o string length 1} length + ? {o string tolower 2} tolower + ? {o string toupper 2} \ + {Unable to dispatch sub-method "toupper" of ::o string; valid are: string info, string length, string tolower} + + ? {o foo a x} "x" + ? {o foo a y} "y" + ? {o foo a z} \ + {Unable to dispatch sub-method "z" of ::o foo a; valid are: foo a defaultmethod, foo a subcmdName, foo a unknown, foo a x, foo a y} + + ? {o info method type string} object + # the following is a problem, when string has subcmd "info" + #? {o::string info class} ::nx::EnsembleObject + + ? {o string length aaa} "length" + ? {o string info class} "info" + ? {o string hugo} \ + {Unable to dispatch sub-method "hugo" of ::o string; valid are: string info, string length, string tolower} + + Foo create f1 + ? {f1 baz a m1 10} m1 + ? {f1 baz a m3 10} \ + {Unable to dispatch sub-method "m3" of ::f1 baz a; valid are: baz a m1, baz a m2} + +#unable to dispatch method baz a m3; valid subcommands of a: m1 m2} +# + +Test parameter count 1 +Test case defaultmethod { + Object create o { + :method "string length" x {return [current method]} + :method "string tolower" x {return [current method]} + :method "string info" x {return [current method]} + :method "foo a x" {} {return [current method]} + :method "foo a y" {} {return [current method]} + :method "foo a subcmdName" {} {return [current method]} + :method "foo a defaultmethod" {} {return [current method]} + :method "foo a unknown" args {return [current method]} + :method "foo b" {} {return [current method]} + } + Class create Foo { + :method "bar m1" {a:integer -flag} {;} + :method "bar m2" {x:integer -y:boolean} {;} + :method "baz a m1" {x:integer -y:boolean} {return m1} + :method "baz a m2" {x:integer -y:boolean} {;} + :method "baz b" {} {;} + :create f1 + } + + ? {o string} "Valid submethods of ::o string: info length tolower" + ? {o foo} "Valid submethods of ::o foo: a b" + + ? {f1 bar} "Valid submethods of ::f1 bar: m1 m2" + ? {f1 baz} "Valid submethods of ::f1 baz: a b" + ? {f1 baz a} "Valid submethods of ::f1 baz a: m1 m2" +} + +# +# testing ensemble objects with next +# +Test parameter count 1 +Test case ensemble-next { + + nx::Class create FOO { + # reduced ensemble + :method foo args {lappend :v "FOO.foo//[nx::current method] ([nx::current args])"} + + # expanded ensemble + :method "l1 l2 l3a" {x} { + lappend :v "FOO.l1 l2 l3a//[nx::current method] ([nx::current args])" + } + :method "l1 l2 l3b" {x} { + lappend :v "FOO.l1 l2 l3b//[nx::current method] ([nx::current args])" + } + # uplevel + :method "bar x" {varname} {upvar $varname v; return [info exists v]} + :method "baz" {} { + set hugo 1 + return [:bar x hugo] + } + } + nx::Class create M0 { + :method "foo b x" {x} { + lappend :v "M0.foo b x//[nx::current method] ([nx::current args])" + nx::next + } + :method "foo b y" {x} { + lappend :v "M0.foo b y//[nx::current method] ([nx::current args])" + nx::next + } + :method "foo a" {x} { + lappend :v "M0.foo a//[nx::current method] ([nx::current args])" + nx::next + } + + :method "l1 l2" {args} { + lappend :v "l1 l2//[nx::current method] ([nx::current args])" + nx::next + } + } + + nx::Class create M1 { + :method "foo a" {x} { + set :v [list "M1.foo a //[nx::current method] ([nx::current args])"] + nx::next + } + :method "foo b x" {x} { + set :v [list "M1.foo b x //[nx::current method] ([nx::current args])"] + nx::next + } + :method "foo b y" {x} { + set :v [list "M1.foo b y //[nx::current method] ([nx::current args])"] + nx::next + } + + :method "l1 l2 l3a" {x} { + set :v [list "M1.l1 l2 l3a//[nx::current method] ([nx::current args])"] + nx::next + } + :method "l1 l2 l3b" {x} { + set :v [list "M1.l1 l2 l3b//[nx::current method] ([nx::current args])"] + nx::next + } + } + + FOO mixin {M1 M0} + FOO create f1 + + # + # The last list element shows handling of less deep ensembles + # (longer arg list is passed) + # + ? {f1 foo a 1} "{M1.foo a //a (1)} {M0.foo a//a (1)} {FOO.foo//foo (a 1)}" + ? {f1 foo b x 1} "{M1.foo b x //x (1)} {M0.foo b x//x (1)} {FOO.foo//foo (b x 1)}" + ? {f1 foo b y 1} "{M1.foo b y //y (1)} {M0.foo b y//y (1)} {FOO.foo//foo (b y 1)}" + # + # The middle list element shows shrinking (less deep ensembles), the + # last element shows expansion via mixin (deeper ensemble is reached + # via next) + # + ? {f1 l1 l2 l3a 100} "{M1.l1 l2 l3a//l3a (100)} {l1 l2//l2 (l3a 100)} {FOO.l1 l2 l3a//l3a (100)}" +} + +Test case ensemble-partial-next { + nx::Class create M { + :public method "info has namespace" {} { + nx::next + return sometimes + } + :public method "info has something else" {} { + return something + } + :public method "info has something path" {} { + return [concat [::nsf::current methodpath] [::nsf::current method]] + } + :public method "info has something better" {} { + nx::next + return better + } + :public method foo {} { + return [concat [::nsf::current methodpath] [::nsf::current method]] + } + } + nx::Object mixin add M + nx::Object create o1 + + # call a submethod defined by a mixin, which does a next + ? {o1 info has namespace} sometimes + + # call a submethod, which is not defined by the mixin + ? {o1 info has type Object} 1 + ? {o1 info has type M} 0 + + # call a submethod, which is nowhere defined + ? {o1 info has typo M} \ + {Unable to dispatch sub-method "typo" of ::o1 info has; valid are: info has mixin, info has namespace, info has something better, info has something else, info has something path, info has type} + + # call a submethod, which is only defined in the mixin + ? {o1 info has something else} something + + # call a submethod, which is only defined in the mixin, and which + # does a next (which should not complain) + ? {o1 info has something better} better + + # yet another missing case + ? {o1 info has something wrong} \ + {Unable to dispatch sub-method "wrong" of ::o1 info has something; valid are: info has something better, info has something else, info has something path} + + # call defaultcmds on ensembles + ? {lsort [o1 info has something]} "Valid submethods of ::o1 info has something: better else path" + + # defaultcmd has to return also subcmds of other shadowed ensembles + ? {lsort [o1 info has]} "Valid submethods of ::o1 info has: mixin namespace something type" + ? {lsort [o1 info]} "Valid submethods of ::o1 info: children class filter has info is lookup method methods mixin parent precedence slots vars" + + # returning methodpath in ensemble + ? {o1 info has something path} "info has something path" + + # returning methodpath outside ensemble + ? {o1 foo} "foo" +} + +# +# Check behavior of upvars in ensemble methods +# +Test case ensemble-upvar { + + nx::Class create FOO { + :method "bar0 x" {varname} {upvar $varname v; return [info exists v]} + :method "baz0" {} { + set hugo 1 + return [:bar0 x hugo] + } + :method "bar1 x" {varname} {:upvar $varname v; return [info exists v]} + :method "baz1" {} { + set hugo 1 + return [:bar1 x hugo] + } + :create f1 + } + + ? {f1 baz0} 0 + ? {f1 baz1} 1 +} + +# +# Check behavior of next with arguments within an ensemble +# +Test case ensemble-next-with-args { + nx::Object create o { + :method foo {x} {return $x} + :method "e1 sm" {x} {return $x} + :method "e2 sm1 sm2" {x} {return $x} + :method "e2 e2 e2" {x} {return $x} + :method "e1 e1 e1" args {return $args} + } + nx::Class create M { + :method foo {} {next 1} + :method "e1 sm" {} {next 2} + :method "e2 sm1 sm2" {} {next 3} + :method "e2 e2 e2" {} {next 4} + :method "e1 e1 e1" args {next {e1 e1 e1}} + } + o mixin add M + + # case without ensemble + ? {o foo} 1 + + # ensemble depth 1, 1 arg + ? {o e1 sm} 2 + + # ensemble depth 2, 1 arg + ? {o e2 sm1 sm2} 3 + + # ensemble depth 2, 1 arg, same tcl-objs + ? {o e2 e2 e2} 4 + + # ensemble depth 2, multiple args, same tcl-objs + ? {o e1 e1 e1} {e1 e1 e1} +} Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/tcl86.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/tcl86.test =================================================================== diff -u --- tests/tcl86.test (revision 0) +++ tests/tcl86.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,85 @@ +# -*- Tcl *-* +package require nx +package require nx::test + +# just 8.6 or similar +if {[info command yield] eq ""} return + +# +# Test coroutine / yield +# +Test case number-generator { + + nx::Object create numbers { + + # set instance variable used in coroutine + set :delta 2 + + :public method ++ {} { + yield + set i 0 + while 1 { + yield $i + incr i ${:delta} + } + } + } + + # create coroutine + coroutine nextNumber numbers ++ + set ::j 0 + + # use coroutine + for {set i 0} {$i < 10} {incr i} { + incr ::j [nextNumber] + } + + # remove coroutine + rename nextNumber {} + + ? {set ::j} 90 +} + +# +# apply +# +Test case apply { + + # Register apply as an alias + ::nx::Object public alias apply ::apply + + ::nx::Object create o { + # Set an object variable + set :delta 100 + + # Define a standard map function based on apply + :public method map {lambda list} { + set result {} + foreach item $list { + lappend result [:apply $lambda $item] + } + return $result + } + + :method foo {x} {return $x-$x} + } + + # Two examples from the apply man page + ? {o map {x {return [string length $x]:$x}} {a bb ccc dddd}} \ + "1:a 2:bb 3:ccc 4:dddd" + ? {o map {x {expr {$x**2 + 3*$x - 2}}} {-4 -3 -2 -1 0 1 2 3 4}} \ + "2 -2 -4 -4 -2 2 8 16 26" + + ## Test case accessing object specific variable + #? {o map {x {::nsf::__db_show_stack; return [expr {$x * ${:delta}}]}} {-4 -3 -2 -1 0 1 2 3 4}} \ + # "-400 -300 -200 -100 0 100 200 300 400" + + # Test case accessing object specific variable + ? {o map {x {expr {$x * ${:delta}}}} {-4 -3 -2 -1 0 1 2 3 4}} \ + "-400 -300 -200 -100 0 100 200 300 400" + + # Test case calling own method via apply + ? {o map {x {:foo $x}} {hello world}} \ + "hello-hello world-world" +} + Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/var-access.tcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/var-access.test =================================================================== diff -u --- tests/var-access.test (revision 0) +++ tests/var-access.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,74 @@ +# -*- Tcl *-* +package require nx +::nx::configure defaultMethodCallProtection false +package require nx::test + +namespace eval ::nx::var1 { + namespace ensemble create -map { + exists ::nsf::existsvar + import ::nsf::importvar + set ::nsf::setvar + } +} + +::nx::Object create ::nx::var2 { + :alias exists ::nsf::existsvar + :alias import ::nsf::importvar + :alias set ::nsf::setvar +} + +Test parameter count 10000 +Test case dummy { + nx::Object create o { + set :x 1 + } + nx::Object create p { + set :y 1 + :method foo0 {} { + incr :y + } + :method foo1 {} { + o eval {incr :x} + } + :method foo2 {} { + ::nsf::importvar o x + incr x + } + :method foo3 {} { + ::nx::var1 import o x + incr x + } + :method foo4 {} { + ::nx::var2 import o x + incr x + } + } + + ? {::nsf::setvar o x} 1 + ? {::nsf::existsvar o x} 1 + ? {::nsf::existsvar o y} 0 + + ? {::nx::var1 set o x} 1 + ? {::nx::var1 exists o x} 1 + ? {::nx::var1 exists o y} 0 + + ? {::nx::var2 set o x} 1 + ? {::nx::var2 exists o x} 1 + ? {::nx::var2 exists o y} 0 + + ? {p foo0} 2 + + ? {p foo1} 2 + ? {::nsf::setvar o x} 10002 + + ? {p foo2} 10003 + ? {::nsf::setvar o x} 20003 + + ? {p foo3} 20004 + ? {::nsf::setvar o x} 30004 + + ? {p foo4} 30005 + ? {::nsf::setvar o x} 40005 +} + +puts stderr =====END Index: tests/varresolution.test =================================================================== diff -u --- tests/varresolution.test (revision 0) +++ tests/varresolution.test (revision 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397) @@ -0,0 +1,1080 @@ +# -*- Tcl *-* +# +# testing var resolution +# +package require nx; namespace import ::nx::* +::nx::configure defaultMethodCallProtection false +package require nx::test + +Test parameter count 1 + +::nsf::alias ::nx::Object objeval -frame object ::eval +::nsf::alias ::nx::Object array -frame object ::array +::nsf::alias ::nx::Object lappend -frame object ::lappend +::nsf::alias ::nx::Object incr -frame object ::incr +::nsf::alias ::nx::Object set -frame object ::set +::nsf::alias ::nx::Object unset -frame object ::unset + +########################################### +# Basic tests for var resolution under +# per-object namespaces ... +########################################### +Test case globals +set ::globalVar 1 +Object create o +o require namespace +? {o info vars} "" +? {info exists ::globalVar} 1 +? {set ::globalVar} 1 +? {o eval {info exists :globalVar}} 0 +? {o array exists globalVar} 0 +o array set globalVar {1 2} +? {o eval {info exists :globalVar}} 1 +? {o info vars} globalVar +? {o array exists globalVar} 1 +? {set ::globalVar} 1 +? {o set globalVar(1)} 2 + +o destroy +unset ::globalVar + +########################################### +# scopes +########################################### +Test case scopes + +Object create o +Object create o2 {set :i 1} +o objeval { + # require an namespace within an objscoped frame; it is necessary to replace + # vartables on the stack + :require namespace + global g + ::nsf::importvar o2 i + set x 1 + set :y 2 + set ::z 3 + set [current]::X 4 + set g 1 + set :a(:b) 1 + set :a(::c) 1 +} +? {::nsf::importvar o2 j} \ + "importvar cannot import variable 'j' into method scope; not called from a method frame" + +o method foo {} {::nsf::importvar [current] :a} +? {o foo} "variable name \":a\" must not contain namespace separator or colon prefix" + +o method foo {} {::nsf::importvar [current] ::a} +? {o foo} "variable name \"::a\" must not contain namespace separator or colon prefix" + +o method foo {} {::nsf::importvar [current] a(:b)} +? {o foo} "can't make instance variable a(:b) on ::o: Variable cannot be an element in an array; use e.g. an alias." + +o method foo {} {::nsf::importvar [current] {a(:b) ab}} +? {o foo} "" + +o method foo {} {::nsf::existsvar [current] ::a} +? {o foo} "variable name \"::a\" must not contain namespace separator or colon prefix" + +o method foo {} {::nsf::existsvar [current] a(:b)} +? {o foo} 1 + +o method foo {} {::nsf::existsvar [current] a(::c)} +? {o foo} 1 + +set ::o::Y 5 +? {info vars ::x} "" + +? {info exists ::z} 1 +? {set ::z} 3 +? {lsort [o info vars]} {X Y a g i x y} +? {o eval {info exists :x}} 1 +? {o eval {info exists :y}} 1 +? {o eval {info exists :z}} 0 +? {o eval {info exists :X}} 1 +? {o eval {info exists :Y}} 1 +? {o set y} 2 +? {set ::g} 1 + +o destroy +o2 destroy +unset ::z +unset ::g + +# like the example above, but with the non-leaf initcmd + +Object create o2 {set :i 1} +Object create o { + :require namespace + global g + ::nsf::importvar o2 i + set x 1 + set :y 2 + set ::z 3 + set [current]::X 4 + set g 1 +} +set ::o::Y 5 +? {info vars ::x} "" + +? {info exists ::z} 1 +? {set ::z} 3 +? {lsort [o info vars]} {X Y y} +? {o eval {info exists :x}} 0 +? {o eval {info exists :y}} 1 +? {o eval {info exists :z}} 0 +? {o eval {info exists :X}} 1 +? {o eval {info exists :Y}} 1 +? {o set y} 2 +? {set ::g} 1 + +o destroy +o2 destroy +unset ::z +unset ::g +foreach v {::x ::z ::g} {unset -nocomplain $v} + +########################################### +# var exists tests +########################################### +Test case exists { + set y 1 + + Object create o {set :x 1} + o method foo {} {info exists :x} + o method bar {} {info exists :y} + ? {o eval {info exists :x}} 1 + ? {o eval {info exists :y}} 0 + ? {o eval {info exists x}} 0 + ? {o foo} 1 + ? {o bar} 0 + ? {::nx::var exists o x} 1 + ? {::nx::var exists o y} 0 + ? {::nx::var exists o :x} {variable name ":x" must not contain namespace separator or colon prefix} + ? {::nx::var exists o :y} {variable name ":y" must not contain namespace separator or colon prefix} + ? {::nx::var set o y 2} 2 + ? {::nx::var exists o y} 1 + ? {::nx::var set o :y 2} {variable name ":y" must not contain namespace separator or colon prefix} +} + +########################################### +# mix & match namespace and object interfaces +########################################### +Test case namespaces + +Object create o +o require namespace +o set x 1 +? {namespace eval ::o {set x}} 1 +? {::o set x} 1 +? {namespace eval ::o {set x 3}} 3 +? {::o set x} 3 +? {namespace eval ::o {info exists x}} 1 +? {::o unset x} "" +? {::nsf::existsvar o x} 0 +? {o eval {info exists :x}} 0 +? {info vars ::x} "" +? {namespace eval ::o {info exists x}} 0 +o lappend y 3 +? {namespace eval ::o {llength y}} 1 +? {namespace eval ::o {unset y}} "" +? {o eval {info exists :y}} 0 +o destroy + +########################################### +# array-specific tests +########################################### +Test case namespaces-array + +Object create o +o require namespace + +? {o array exists a} 0 +? {namespace eval ::o array exists a} 0 +o array set a {1 2 3 4 5 6} +? {o array exists a} 1 +? {namespace eval ::o array exists a} 1 +? {namespace eval ::o array names a} [::o array names a] +? {namespace eval ::o array size a} [::o array size a] +? {o set a(1) 7} 7 +? {namespace eval ::o array get a 1} {1 7} +? {namespace eval ::o set a(1) 2} 2 +? {o array get a 1} {1 2} +? {::o unset a} "" +? {::o array unset a} "" +? {o array exists a} 0 +? {namespace eval ::o array exists a} 0 + +o destroy + +########################################### +# tests on namespace-qualified var names +########################################### +Test case namespaced-var-names +Object create o +o require namespace +Object create o::oo +o::oo require namespace + +? {::o set ::x 1} 1 +? {info exists ::x} [set ::x] +? {catch {unset ::x}} 0 + +? {::o set ::o::x 1} 1 +? {o eval {info exists :x}} [::o set ::o::x] +? {namespace eval ::o unset x} "" +? {o eval {info exists x}} 0 + +# Note, relatively qualified var names (not prefixed with ::*) +# are always resolved relative to the per-object namespace +? {catch {::o set o::x 1} msg} 1 +? {::o set oo::x 1} 1 +? {o::oo eval {info exists :x}} [::o set oo::x] +? {o unset oo::x} "" +? {o::oo eval {info exists :x}} 0 + +o destroy + +########################################### +# tests on namespace-qualified on objects +# without namespaces +########################################### + +# the tests below fail. We could consider +# to require namespaces on the fly in the future +#Object create o +#? {::o set ::o::x 1} 1 +#? {o exists x} [::o set ::o::x] +#? {namespace eval ::o unset x} "" +#? {o exists x} 0 + +#? {::o set o::x 1} 1 +#? {o exists x} [::o set o::x] +#? {namespace eval ::o unset x} "" +#? {o exists x} 0 + +#o destroy + +############################################### +# tests for the compiled var resolver on Object +############################################### +Test case var-resolver-object +Object create o +o method foo {x} {set :y 2; return ${:x},${:y}} +o method bar {} {return ${:x},${:y}} +o set x 1 +? {o foo 1} "1,2" "create var y and fetch var x" +? {o bar} "1,2" "fetch two instance variables" +? {o info vars} "x y" +# recreate object, check var caching; +# we have to recreate bar, so no problem +Object create o +o set x 1 +o method bar {} {return ${:x},${:y}} +? {catch {o bar}} "1" "compiled var y should not exist" +o destroy + +############################################### +# tests for the compiled var resolver on Class +############################################### +Test case var-resolver-class +Class create C -attributes {{x 1}} +C create c1 +C method foo {x} {set :y 2; return ${:x},${:y}} +C method bar {} {return ${:x},${:y}} +? {c1 info vars} "x" +? {c1 foo 1} "1,2" "create var y and fetch var x" +? {c1 bar} "1,2" "fetch two instance variables" +? {c1 info vars} "x y" +# recreate object, check var caching; +# we do not have to recreate bar, compiled var persists, +# change must be detected +C create c1 +#puts stderr "after recreate" +? {catch {c1 bar}} "1" "compiled var y should not exist" +? {c1 info vars} "x" +c1 destroy +C destroy + + + +############################################### +# tests for the compiled var resolver with eval +############################################### +Test case compiled-var-resolver +Class create C -attributes {{x 1}} +C create c1 +C method foo {x} { + set :y 2; + eval "set :z 3" + return ${:x},${:y},${:z} +} +? {c1 info vars} "x" +? {c1 foo 1} "1,2,3" +? {c1 info vars} "x y z" +C create c1 +? {c1 info vars} "x" +C method foo {x} { + set cmd set + lappend cmd :y + lappend cmd 100 + eval $cmd + return $x,${:y} +} +C method bar {} {return [info exists :x],[info exists :y]} +C method bar2 {} {if {[info exists :x]} {set :x 1000}; return [info exists :x],[info exists :y]} +? {c1 foo 1} "1,100" +? {c1 bar} "1,1" +? {c1 bar2} "1,1" +c1 unset x +? {c1 bar2} "0,1" +c1 destroy +C destroy + +############################################### +# tests with array +############################################### + +Class create C +C create c1 +C method foo {} { + array set :a {a 1 b 2 c 3} + set :z 100 +} +? {c1 info vars} "" +c1 foo +? {lsort [c1 info vars]} {a z} + +############################################### +# tests for the var resolver +############################################### +Test case var-resolver +Class create C +C method bar0 {} {return ${:x}} +C method bar1 {} {set a ${:x}; return [info exists :x],[info exists :y]} +C method bar2 {} {return [info exists :x],[info exists :y]} +C method foo {} { + array set :a {a 1 b 2 c 3} + set :z 100 +} +C create c1 +c1 set x 100 +? {c1 bar0} 100 "single compiled local" +? {c1 bar1} 1,0 "lookup one compiled var and one non-existing" +? {c1 bar2} 1,0 "lookup one non compiled var and one non-existing" +C create c2 +? {c2 bar2} 0,0 "lookup two one non-existing, first access to varTable" +c1 foo +? {lsort [c1 info vars]} "a x z" "array variable set via resolver" +? {lsort [c1 array names a]} "a b c" "array looks ok" + +############################################### +# first tests for the cmd resolver +############################################### +Class create C +C method bar {args} { + #puts stderr "[current] bar called with [list $args]" + return $args +} +C forward test %self bar +C method foo {} { + # this works + lappend :r [:bar x 1] + lappend :r [:test a b c] + # these kind of works, but vars are nowhere.... + :set x 1 + :incr x 1 + :incr x 1 + return [lappend :r ${:x}] +} +C create c3 +? {c3 foo} "{x 1} {a b c} 3" + +############################################### +# refined tests for the var resolver under +# Tcl namespaces parallelling XOTcl objects +# (! not declared through require namespace !) +# e.g., "info has namespace" reports 0 rather +# than 1 as under "require namespace" +############################################### + +set ::w 1 +array set ::tmpArray {key value} + +Class create ::C +::nsf::alias ::C Set -frame object ::set +::nsf::alias ::C Unset -frame object ::unset + +::C create ::c +namespace eval ::c {} +? {namespace exists ::c} 1 +? {::nsf::isobject ::c} 1 +? {::c info has namespace} 0 + +? {::c Set w 2; expr {[::c Set w] == $::w}} 0 +? {::c Unset w; info exists ::w} 1 +? {::c Set tmpArray(key) value2; expr {[::c Set tmpArray(key)] == $::tmpArray(key)}} 0 +? {::c Unset tmpArray(key); info exists ::tmpArray(key)} 1 + +::c destroy +::C destroy +unset ::w +unset ::tmpArray + +################################################## +# Testing aliases for eval with and without +# -varscope flags and with a +# required namespace and without +################################################## +Test case eval-variants +::nsf::alias ::nx::Object objeval -frame object ::eval +::nsf::alias ::nx::Object softeval -frame method ::eval +::nsf::alias ::nx::Object softeval2 ::eval + +set G 1 + +Object create o { + set xxx 1 + set :x 1 + ? {info exists G} 1 +} +? {o eval {info exists :x}} 1 +? {o eval {info exists :xxx}} 0 + +? {info exists ::xxx} 0 +unset -nocomplain ::xxx + +# eval does an objcope, all vars are instance variables; can access preexisting global vars +o objeval { + set aaa 1 + set :a 1 + ? {info exists G} 1 +} + +? {o eval {info exists :a}} 1 +? {o eval {info exists :aaa}} 1 + +? {info exists ::aaa} 0 +unset -nocomplain ::aaa + +# softeval (with -nonleaf) behaves like the initcmd and sets just +# instance variables via resolver. + +o softeval { + set bbb 1 + set :b 1 + ? {info exists G} 1 +} +? {o eval {info exists :b}} 1 +? {o eval {info exists :bbb}} 0 + +? {info vars ::bbb} "" +unset -nocomplain ::bbb + +# softeval2 never sets instance variables +o softeval2 { + set zzz 1 + set :z 1 + ? {info exists G} 1 +} +? {o eval {info exists :z}} 0 +? {o eval {info exists :zzz}} 0 + +? {info vars ::zzz} ::zzz +unset -nocomplain ::zzz + +? {lsort [o info vars]} "a aaa b x" +o destroy + +# now with an object namespace +Object create o +o require namespace + +# objeval does an objcope, all vars are instance variables +o objeval { + set ccc 1 + set :c 1 +} +? {o eval {info exists :c}} 1 +? {o eval {info exists :ccc}} 1 + +# softeval behaves like the creation initcmd (just set dot vars) +o softeval { + set ddd 1 + set :d 1 +} +? {o eval {info exists :d}} 1 +? {o eval {info exists :ddd}} 0 + +# softeval2 never sets variables +o softeval2 { + set zzz 1 + set :z 1 +} +? {o eval {info exists :z}} 0 +? {o eval {info exists :zzz}} 0 +? {lsort [o info vars]} "c ccc d" +o destroy + +################################################################# +# The same as above, but with some global vars. The global vars +# should not influence the behavior on instance variables +################################################################# +Test case with-global-vars +foreach var {.x x xxx :a a aaa :b b bbb :c c ccc :d d ddd :z z zzz} {set $var 1} + +Object create o { + set xxx 1 + set :x 1 +} +? {o eval {info exists :x}} 1 +? {o eval {info exists :xxx}} 0 + +# objeval does an objcope, all vars are instance variables +o objeval { + set aaa 1 + set :a 1 +} +? {o eval {info exists :a}} 1 +? {o eval {info exists :aaa}} 1 + +# softeval should behave like the creation initcmd (just set dot vars) +o softeval { + set bbb 1 + set :b 1 +} +? {o eval {info exists :b}} 1 +? {o eval {info exists :bbb}} 0 + +# softeval2 never sets instance variables +o softeval2 { + set zzz 1 + set :z 1 +} +? {o eval {info exists :z}} 0 +? {o eval {info exists :zzz}} 0 + +? {lsort [o info vars]} "a aaa b x" +o destroy + +# now with namespace +Object create o +o require namespace + +# eval does an objcope, all vars are instance variables +o objeval { + set ccc 1 + set :c 1 +} +? {o eval {info exists :c}} 1 +? {o eval {info exists :ccc}} 1 + +# softeval2 should behave like the creation initcmd (just set dot vars) +o softeval { + set ddd 1 + set :d 1 +} +? {o eval {info exists :d}} 1 +? {o eval {info exists :ddd}} 0 + +# softeval2 never sets variables +o softeval2 { + set zzz 1 + set :z 1 +} +? {o eval {info exists :z}} 0 +? {o eval {info exists :zzz}} 0 +? {lsort [o info vars]} "c ccc d" +o destroy + +################################################## +# Test with proc scopes +################################################## +Test case proc-scopes +::nsf::alias ::nx::Object objscoped-eval -frame object ::eval +::nsf::alias ::nx::Object nonleaf-eval -frame method ::eval +::nsf::alias ::nx::Object plain-eval ::eval + +proc foo-via-initcmd {} { + foreach v {x xxx} {unset -nocomplain ::$v} + set p 1 + Object create o { + set xxx 1 + set :x 1 + set ::result G=[info exists G],p=[info exists p] + } + return [o eval {info exists :x}]-[o eval {info exists :xxx}]-[info exists x]-[info exists xxx]-[info exists ::x]-[info exists ::xxx]-$::result +} + +proc foo {type} { + foreach v {x xxx} {unset -nocomplain ::$v} + set p 1 + Object create o + o $type { + set xxx 1 + set :x 1 + set ::result G=[info exists G],p=[info exists p] + } + return [o eval {info exists :x}]-[o eval {info exists :xxx}]-[info exists x]-[info exists xxx]-[info exists ::x]-[info exists ::xxx]-$::result +} + +proc foo-tcl {what} { + foreach v {x xxx} {unset -nocomplain ::$v} + set p 1 + set body { + set xxx 1 + set :x 1 + set ::result G=[info exists G],p=[info exists p] + } + switch $what { + eval {eval $body} + ns-eval {namespace eval [namespace current] $body} + } + return [o eval {info exists :x}]-[o eval {info exists :xxx}]-[info exists x]-[info exists xxx]-[info exists ::x]-[info exists ::xxx]-$::result +} + +set G 1 + + + ? {foo-via-initcmd} 1-0-0-0-0-0-G=0,p=0 + ? {foo nonleaf-eval} 1-0-0-0-0-0-G=0,p=0 + ? {foo objscoped-eval} 1-1-0-0-0-0-G=0,p=0 + ? {foo plain-eval} 0-0-0-1-0-0-G=0,p=1 + ? {foo-tcl eval} 0-0-0-1-0-0-G=0,p=1 + ? {foo-tcl ns-eval} 0-0-0-0-0-1-G=1,p=0 + +################################################## +# dotCmd tests +################################################## +Test case dotcmd +set C 0 +proc bar {} {incr ::C} +Class create Foo { + :method init {} {set :c 0} + :method callDot1 {} {:bar} + :method callDot2 {} {:bar} + :method callDot3 {} {:bar; ::bar; :bar} + :method bar {} {incr :c} +} + +Foo create f1 +f1 callDot1 +? {set ::C} 0 +? {f1 eval {set :c}} 1 + +# call via callback +after 1 {f1 callDot2} +after 10 {set ::X 1} +vwait X + +? {set ::C} 0 +? {f1 eval {set :c}} 2 + +# call via callback, call :bar via .. from method +after 1 {f1 callDot3} +after 10 {set ::X 2} +vwait X + +? {set ::C} 1 +? {f1 eval {set :c}} 4 + + +################################################## +# test for namespace resolver +################################################## +Test case nsresolver +namespace eval module { + Class create C + Class create M1 + Class create M2 + + C mixin M1 + ? {::nsf::relation C class-mixin} "::module::M1" + + C mixin add M2 + ? {::nsf::relation C class-mixin} "::module::M2 ::module::M1" +} + + +################################################## +# test setting of instance variables for +# objects with namespaces in and outside +# of an eval (one case uses compiler) +################################################## + +Test case alias-dot-resolver-interp +# outside of eval scope (interpreted) +Class create V { + set :Z 1 + set ZZZ 1 + :method bar {z} { return $z } + :class-object method bar {z} { return $z } + :create v { + set zzz 2 + set :z 2 + } +} +? {lsort [V info vars]} {Z} +? {lsort [v info vars]} {z} + +# dot-resolver/ dot-dispatcher used in aliased proc + +Test case alias-dot-resolver { + + Class create V { + set :Z 1 + set ZZZ 1 + :method bar {z} { return $z } + :class-object method bar {z} { return $z } + :create v { + set :z 2 + set zzz 2 + } + } + ? {lsort [V info vars]} {Z} + ? {lsort [v info vars]} {z} +} + +# +# test [info vars] in eval method +# + +Test case info-vars-in-eval { + + Object create o + ? {o eval { + set x 1 + expr {[info vars "x"] eq "x"} + }} 1 +} + +# +# test for former crash when variable is used in connection with +# prefixed variables +# +Test case tcl-variable-cmd { + Object create o { + :public method ? {varname} {info exists :$varname} + :public method bar args { + variable :a + set a 3 + variable b + set b 3 + variable c 1 + variable :d 1 + :info vars + } + } + + ? {o bar} "" + ? {o ? a} 0 + ? {o ? b} 0 + ? {o ? c} 0 + ? {o ? d} 0 + ? {lsort [o info vars]} "" + o eval {set :a 1} + ? {o ? a} 1 + ? {lsort [o info vars]} a +} + +Test case interactions { + + # SS: Adding an exemplary test destilled from the behaviour observed + # for AOLserver vs. NaviServer when introspecting object variables + # by means of the colon-resolver interface. It exemplifies the (by now + # resolved for good) interactions between: (a) the compiling and + # non-compiling var resolvers and (b) compiled and non-compiled + # script execution + + Object create ::o { + :public method bar {} { + # 1. creates a proc-local, compiled var "type" + set type 1 + # 2. at compile time: create a proc-local, compiled link-var ":type" + info exists :type + # 3. at (unoptimised) interpretation time: bypasses compiled link-var + # ":type" (invokeStr instruction; a simple eval), does a var + # lookup with ":type", handled by InterpColonVarResolver(); + # CompiledLocalsLookup() receives the var name (i.e., ":type") + # and finds the proc-local compiled var ":type" (actually a link + # variable to the actual/real object variable). + eval {info exists :type}; + # Note! A [info exists :type] would have been optimised on the + # bytecode fastpath (i.e., existsScalar instruction) and would + # use the compiled-local link-var ":type" directly (without + # visiting InterpColonVarResolver()!) + } + } + + ? {o bar} 0 + + # + # document compile-time var resolver side effects: link variables + # + # At compile time, the compile-time var resolver looks up (and + # creates) object variables for the colon-prefixed vars processed: + # ":u" -> "u", ":v" -> "v"; hence, the resolver always returns a + # Var structure! As a consequence, the compiler emits + # colon-prefixed *link* variables (either in state "undefined" or + # "defined", depending on providing a value or not) into the + # compiled local array (e.g., ":u"), as proxies pointing to the + # actual object variables (e.g., "u"). + # + # Consequences: These link vars are visible through introspection + # sensible to created vars (rather than defined/undefined var + # states) in compiled scripts ([info vars] vs. [info locals]). This + # resembles [upvar]-created local link vars, yet it does not + # intuitively compare with the [set]/[unset] behaviour on + # non-prefixed, ordinary variables from the angle of + # introspection. Also, this constitutes an observable behavioural + # difference between compiled and non-compiled scripts ... + + set script { + # early probing: reflects the compiled-only, unexecuted state + set _ [join [list {*}[lsort [info vars :*]] [info locals :*] \ + [info exists :u] [::nsf::existsvar [::nsf::current] u] \ + [info exists :v] [::nsf::existsvar [::nsf::current] v] \ + [info exists :x] [::nsf::existsvar [::nsf::current] x]] "-"] + catch {set :u} + set :v 1 + unset :x + # late probing: reflects the (ideally) compiled, *executed* state + append _ | [join [list {*}[lsort [info vars :*]] [info locals :*] \ + [info exists :u] [::nsf::existsvar [::nsf::current] u] \ + [info exists :v] [::nsf::existsvar [::nsf::current] v] \ + [info exists :x] [::nsf::existsvar [::nsf::current] x]] "-"] + return $_ + } + + # compiled execution + o public method baz {} $script + o eval {set :x 1; unset -nocomplain :v} + ? {o baz} :u-:v-:x--0-0-0-0-1-1|:u-:v-:x--0-0-1-1-0-0 ; #:u-:v-:x--1-1-0-0-0-1-0-:u-:v-:x + + # non-compiled execution + o eval {set :x 1; unset -nocomplain :v} + ? [list o eval $script] -0-0-0-0-1-1|-0-0-1-1-0-0 + + # + # testing interactions between the compile-time var resolver and ... + # + + # ... [variable] + # + # background: the [variable] statement is compiled. During + # compilation, our compile-time resolver is contacted, finds (and + # eventually creates) an object variable "x". The compiler machinery + # then creates a link-variable ":x" which is stored as a compiled + # local, as usual. at the time of writing/testing, there are two + # issues with this: + # + # ISSUE 1: In its non-compiled execution, [variable] sets the + # AVOID_RESOLVERS flags, so our resolvers are not touched ... in its + # compiled execution, AVOID_RESOLVERS is missing though (although + # [variable] is compiled into a slow path execution, i.e., involves + # a Tcl var lookup). Therefore, we get a link variable in the + # compiled locals (and an undefined obj var). + + # this has some implications ... + + namespace eval ::ns1 { + Object create o { + :public method foo {} { + set _ [join [list {*}[lsort [info vars :*]] [info locals :*] \ + [info exists w] [::nsf::existsvar [::nsf::current] w] \ + [info exists :x] [::nsf::existsvar [::nsf::current] x]] "-"] + variable w; # -> intention: a variable "w" in the effective namespace (e.g., "::ns1::w") + variable :x; # -> intention: a variable ":x" in the effective namespace (e.g., "::ns1:::x"!). + append _ | [join [list {*}[lsort [info vars :*]] [info locals :*] \ + [info exists w] [::nsf::existsvar [::nsf::current] w] \ + [info exists :x] [::nsf::existsvar [::nsf::current] x]] "-"] + return $_ + } + } + + ? {::ns1::o foo} ":x--0-0-0-0|:x--0-0-0-0" + + o eval { + :public method faz {} { + set _ [join [list {*}[lsort [info vars :*]] [info locals :*] \ + [namespace which -variable [namespace current]::w] \ + [info exists [namespace current]::w] \ + [info exists w] [::nsf::existsvar [::nsf::current] w] \ + [namespace which -variable [namespace current]:::x] \ + [info exists [namespace current]:::x] \ + [info exists :x] [::nsf::existsvar [::nsf::current] x]] "-"] + variable w 1; # -> intention: a variable "w" in the effective namespace (e.g., "::ns1::w") + variable :x 2; # -> intention: a variable ":x" in the effective namespace (e.g., "::ns1:::x"!). + append _ | [join [list {*}[lsort [info vars :*]] [info locals :*] \ + [namespace which -variable [namespace current]::w] \ + [info exists [namespace current]::w] \ + [info exists w] [::nsf::existsvar [::nsf::current] w] \ + [namespace which -variable [namespace current]:::x] \ + [info exists [namespace current]:::x] [namespace eval [namespace current] {info exists :x}] \ + [namespace eval [namespace current] {variable :x; info exists :x}] \ + [info exists :x] [::nsf::existsvar [::nsf::current] x]] "-"] + + append _ | [join [list [expr {$w eq [namespace eval [namespace current] {variable w; set w}]}] \ + [expr {${:x} eq [namespace eval [namespace current] {variable w; set :x}]}]] -] + return $_ + } + } + + ? {::ns1::o faz} ":x--::ns1::w-0-0-0--0-0-0|:x--::ns1::w-1-1-0--0-1-1-1-0|1-1" + + # + # ISSUE 2: Colon-prefixed variables become represented by linked + # variables in the compiled local arrays during + # compilation. However, linked variables are mutable (in contrast + # to proc-local variables), that is, they can be changed to point + # to another target variable. This target switch currently happens + # between object variables and [variable] links which (due to + # executing the compile-time var resolver because of lacking + # AVOID_RESOLVERS) emits a "replacing" link var + # + # In the example below, there won't be an error exception + # 'variable ":aaa" already exists', because ":aaa" is resolved on + # the fly to "::ns1::o1.aaa" in a non-compiled execution and in a + # compiled situation, the compiled-local link variable ":aaa" is + # simply cleared and recreated to proxy a namespace variable. + + o eval { + set :aaa 1 + :public method caz {} { + set _ "[info exists :aaa]-${:aaa}-[set :aaa]" + variable :aaa + append _ "-[info exists :aaa]" + set :aaa 2 + append _ "-${:aaa}-[set :aaa]-[namespace eval [namespace current] {variable :aaa; set :aaa}]" + unset :aaa + append _ "-[info exists :aaa]-[namespace which -variable [namespace current]:::aaa]-[::nsf::existsvar [current] aaa]-[[current] eval {set :aaa}]" + return $_ + } + } + + ? {::ns1::o caz} "1-1-1-0-2-2-2-0--1-1" + + # + # In non-compiled executions, there is another form of interaction + # between our var resolvers and [variable] in the sense of + # switching references. A [variable] statement is then handled by + # Tcl_VariableObjCmd() directly, our compile-time resolver is + # never called, hence, no link variables are created. The + # non-compiling resolver InterpColonVarResolver() is called to + # duty from within Tcl_VariableObjCmd(), however, it fast-forwards + # by signalling TCL_CONTINUE as [variable] requests + # TCL_NAMESPACE_ONLY explicitly. + # + # While [variable] creates a local link var ":aaa", any later + # referencing of :aaa is intercepted by InterpColonVarResolver() + # and resolved to the obj var "aaa". The effects of this + # interaction are probably counter-intuitive to standard + # [variable] behaviour. + # + # 1. There will not be a 'variable ":aaa" already exists' to + # signal a naming conflict in the local naming scope, because the + # symbolic name ":aaa" in a [set :aaa 1] and in a [variable :aaa + # 1] is resolved differently (see above). + # + # 2. There is no way to refer to the local link var ":aaa" created + # by [variable] in subsequent calls because the name will resolve + # to an obj var "aaa". By calling [variable] in its setting mode, + # you can still set namespace var values. + ? {::ns1::o eval { + set _ "[info exists :aaa]-${:aaa}-[set :aaa]" + variable :aaa + append _ "-[info exists :aaa]" + set :aaa 2 + append _ "-${:aaa}-[set :aaa]-[[current] eval {set :aaa}]-[namespace eval [namespace current] {variable :aaa; info exists :aaa}]" + variable :aaa 5 + unset :aaa + append _ "-[info exists :aaa]-[namespace which -variable [namespace current]:::aaa]-[::nsf::existsvar [current] aaa]-[namespace eval [namespace current] {variable :aaa; info exists :aaa}]-[namespace eval [namespace current] {variable :aaa; set :aaa}]" + return $_ + }} "1-1-1-1-2-2-2-0-0--0-1-5" + + + # ... [upvar] + # + # Exhibits the same interactions as [variable] due to creating + # link variables by the compiling var resolver, namely the context + # switching and effective disabling of the colon-prefixed + # accessing of object state ... + # + + Object create p { + :public method foo {var} { + set :x XXX + set _ ${:x} + upvar $var :x + append _ -[join [list ${:x} [set :x] {*}[info vars :*] {*}[:info vars] \ + [info exists :x] \ + [[current] eval {info exists :x}]] "-"] + unset :x + append _ -[join [list {*}[info vars :*] {*}[:info vars] \ + [info exists :x] [[current] eval {info exists :x}] \ + [[current] eval {set :x}]] "-"] + } + + :method bar {var1 var2 var3 var4 var5 var6} { + upvar $var1 xx $var2 :yy $var3 :zz $var4 q $var5 :el1 $var6 :el2 + set _ [join [list {*}[lsort [:info vars]] {*}[lsort [info vars :*]] \ + [info exists xx] $xx \ + [info exists :yy] ${:yy} \ + [info exists :zz] ${:zz} \ + [info exists q] [[current] eval {info exists :q}]] -] + incr :yy + incr xx + incr :zz + incr q + incr :el1 + incr :el2 + return $_ + } + + :public method baz {} { + set :x 10 + set y 20 + set :z 30 + unset -nocomplain :q + set :arr(a) 40 + set _ [:bar :x y :z :q :arr(a) :arr(b)] + append _ -[join [list ${:x} $y ${:z} ${:q} [set :arr(a)] [set :arr(b)] [:info vars q]] -] + } + } + + ? {set y 1; p foo y} "XXX-1-1-:x-x-1-1-:x-x-0-1-XXX" + ? {p baz} "arr-x-z-:el1-:el2-:yy-:zz-1-10-1-20-1-30-0-0-11-21-31-1-41-1-q" + + # + # ... [namespace which] + # + # Similar to the compiled, slow-path [variable] instructions, + # [namespace which] as implemented by NamespaceWhichCmd() in + # tclNamesp.c lacks AVOID_RESOLVERS. Therefore, we end up in our + # var resolver which resolves colon-prefixed vars to object + # variables. Also, NamespaceWhichCmd() does not set any other + # var-resolution flags (TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY) as + # this would defeat its purpose. Anywyays, our resolver is + # therefore completely blind when handling calls from [namespace + # which]. + # + # This leads to the unexpected behaviour in the test below: + # [namespace which -variable :XXX] != [namespace which -variable + # [namespace current]:::XXX] + + o eval { + :public method bar {} { + set :XXX 1 + return [join [list ${:XXX} [set :XXX] [namespace which -variable :XXX] \ + [namespace which -variable [namespace current]:::XXX]] -] + } + } + + ? {::ns1::o bar} "1-1-:XXX-" + } + + + + +} \ No newline at end of file Fisheye: Tag 8bfe3ac01fe62c1917587fc5fe76952d3ff8f397 refers to a dead (removed) revision in file `tests/varresolutiontest.tcl'. Fisheye: No comparison available. Pass `N' to diff?