Index: Makefile.in =================================================================== diff -u -N -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 -N -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 -N --- 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 Index: tests/aliastest.tcl =================================================================== diff -u -N --- tests/aliastest.tcl (revision 440e05aa8a59891a119c4fd5fa3ad4193cedd9a3) +++ tests/aliastest.tcl (revision 0) @@ -1,545 +0,0 @@ -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 Index: tests/destroy.test =================================================================== diff -u -N --- 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 Index: tests/destroytest.tcl =================================================================== diff -u -N --- tests/destroytest.tcl (revision f69e0909fcb180e1cbcdd316f0a20de1b254af3d) +++ tests/destroytest.tcl (revision 0) @@ -1,633 +0,0 @@ -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 Index: tests/doc.tcl =================================================================== diff -u -N --- tests/doc.tcl (revision 5d5f67b7b4a9806e10419e44efdcfe724bfcff9b) +++ tests/doc.tcl (revision 0) @@ -1,1143 +0,0 @@ -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/doc.test =================================================================== diff -u -N --- 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 -N --- 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 Index: tests/forwardtest.tcl =================================================================== diff -u -N --- tests/forwardtest.tcl (revision 18d4d9c1a99310c3fb9b2f2bed03e9d59fb30d30) +++ tests/forwardtest.tcl (revision 0) @@ -1,390 +0,0 @@ -# -*- 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 Index: tests/info-method.tcl =================================================================== diff -u -N --- tests/info-method.tcl (revision c5d841d4cd001b85e95e01202b4fc0afe75df6a8) +++ tests/info-method.tcl (revision 0) @@ -1,401 +0,0 @@ -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 Index: tests/info-method.test =================================================================== diff -u -N --- 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 Index: tests/interceptor-slot.tcl =================================================================== diff -u -N --- tests/interceptor-slot.tcl (revision 17cf9791655c4680499c4ab755df3b49dfa4cf06) +++ tests/interceptor-slot.tcl (revision 0) @@ -1,184 +0,0 @@ -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 - - - - Index: tests/interceptor-slot.test =================================================================== diff -u -N --- 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 + + + + Index: tests/method-modifiers.tcl =================================================================== diff -u -N --- tests/method-modifiers.tcl (revision fbf70aa67bec4deec1078074787aafb8b66b2dde) +++ tests/method-modifiers.tcl (revision 0) @@ -1,311 +0,0 @@ -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" -} Index: tests/method-modifiers.test =================================================================== diff -u -N --- 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" +} Index: tests/method-require.tcl =================================================================== diff -u -N --- tests/method-require.tcl (revision c5d841d4cd001b85e95e01202b4fc0afe75df6a8) +++ tests/method-require.tcl (revision 0) @@ -1,58 +0,0 @@ -package require nx; # namespace import -force ::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/method-require.test =================================================================== diff -u -N --- 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 -N --- 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} "" +} + + Index: tests/mixinoftest.tcl =================================================================== diff -u -N --- tests/mixinoftest.tcl (revision 27e11788125901ff468955117d165f70d3871ce0) +++ tests/mixinoftest.tcl (revision 0) @@ -1,514 +0,0 @@ -# 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} "" -} - - Index: tests/object-system.tcl =================================================================== diff -u -N --- tests/object-system.tcl (revision c5d841d4cd001b85e95e01202b4fc0afe75df6a8) +++ tests/object-system.tcl (revision 0) @@ -1,214 +0,0 @@ -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 Index: tests/object-system.test =================================================================== diff -u -N --- 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 Index: tests/parameters.tcl =================================================================== diff -u -N --- tests/parameters.tcl (revision f69e0909fcb180e1cbcdd316f0a20de1b254af3d) +++ tests/parameters.tcl (revision 0) @@ -1,1316 +0,0 @@ -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 Index: tests/parameters.test =================================================================== diff -u -N --- 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 Index: tests/protected.tcl =================================================================== diff -u -N --- tests/protected.tcl (revision 18d4d9c1a99310c3fb9b2f2bed03e9d59fb30d30) +++ tests/protected.tcl (revision 0) @@ -1,101 +0,0 @@ -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!} - Index: tests/protected.test =================================================================== diff -u -N --- 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!} + Index: tests/returns.tcl =================================================================== diff -u -N --- tests/returns.tcl (revision c5d841d4cd001b85e95e01202b4fc0afe75df6a8) +++ tests/returns.tcl (revision 0) @@ -1,291 +0,0 @@ -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} -} Index: tests/returns.test =================================================================== diff -u -N --- 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} +} Index: tests/submethods.tcl =================================================================== diff -u -N --- tests/submethods.tcl (revision 18d4d9c1a99310c3fb9b2f2bed03e9d59fb30d30) +++ tests/submethods.tcl (revision 0) @@ -1,294 +0,0 @@ -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} -} Index: tests/submethods.test =================================================================== diff -u -N --- 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} +} Index: tests/tcl86.tcl =================================================================== diff -u -N --- tests/tcl86.tcl (revision 35dda6764f7fde6a68c1076deaaaec9e40ad899e) +++ tests/tcl86.tcl (revision 0) @@ -1,84 +0,0 @@ -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" -} - Index: tests/tcl86.test =================================================================== diff -u -N --- 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" +} + Index: tests/var-access.tcl =================================================================== diff -u -N --- tests/var-access.tcl (revision 18d4d9c1a99310c3fb9b2f2bed03e9d59fb30d30) +++ tests/var-access.tcl (revision 0) @@ -1,73 +0,0 @@ -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/var-access.test =================================================================== diff -u -N --- 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 -N --- 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 Index: tests/varresolutiontest.tcl =================================================================== diff -u -N --- tests/varresolutiontest.tcl (revision 41e9fc1ab4528c400941f5897b6aca09112f22aa) +++ tests/varresolutiontest.tcl (revision 0) @@ -1,1079 +0,0 @@ -# -# 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