Index: Makefile.in =================================================================== diff -u -re277bc35923104b11181d60d4ed377653b337d40 -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- Makefile.in (.../Makefile.in) (revision e277bc35923104b11181d60d4ed377653b337d40) +++ Makefile.in (.../Makefile.in) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -232,7 +232,7 @@ done; fi; libraries-pkgindex: - @$(TCLSH) $(src_lib_dir_native)/lib/make.xotcl -dir $(src_lib_dir_native) -all + @$(TCLSH) $(src_lib_dir_native)/lib/make.tcl -dir $(src_lib_dir_native) -all fulldoc: doc pdf # use language reference as sample file to trigger generation of documentation files @@ -345,14 +345,15 @@ #TESTFLAGS = -srcdir $(srcdir) test-core: $(TCLSH_PROG) $(TCLSH) $(src_test_dir_native)/object-system.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/destroytest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/destroytest.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/method-modifiers.xotcl -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.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/parameters.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/info-method.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) + $(TCLSH) $(src_test_dir_native)/parameters.tcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/interceptor-slot.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/aliastest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) - $(TCLSH) $(src_test_dir_native)/protected.xotcl -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)/testx.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/testo.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) $(TCLSH) $(src_test_dir_native)/speedtest.xotcl -libdir $(PLATFORM_DIR) $(TESTFLAGS) Index: TODO =================================================================== diff -u -ra98ffcaf356b6d0a1e9d58ae7d0835ed11f56fa3 -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- TODO (.../TODO) (revision a98ffcaf356b6d0a1e9d58ae7d0835ed11f56fa3) +++ TODO (.../TODO) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -825,12 +825,29 @@ Now both definition of parameters and setting of __parameter are in Tcl. +- get rid of ":::xotcl::use" +- renamed tests based on next from .xotcl to .tcl +- extended regression tests +- use namespace ::nx::test instead of ::xotcl::test +- use namespace ::nx::serializer instead of ::xotcl::serializer + TODO: -- rename source files from xotcl{Int}.{ch}->next*.* | next-scripting*.* ? - Stefan, meinung dazu? Notwending|Empfehlenswert|nicht? - bei den TEA definitionen stand was von max. 8zeichen für source code namen. - andere optionen? +- nameing + * .c-code: + . rename source files from xotcl{Int}.{ch}->next*.* | next-scripting*.* ? + Stefan, meinung dazu? Notwending|Empfehlenswert|nicht? + bei den TEA definitionen stand was von max. 8zeichen für source code namen. + andere optionen? + . prefix for exported symbols (XOTcl_ -> ?) + . prefix for symbols (XOTcl->?) + . prefix for symbols (XO->?) + * file extension for next scripting .tcl + * namespace prefix + next scripting language: ::nx::* + next scripting framework: ::nx::core::* + * distributed packages in namespace ::nx::* + * names of subpackages next::* - documentation - documentationssytem @@ -853,7 +870,11 @@ TODO "Kleinigkeiten" -- rename tests from .xotcl to .tcl +- rename xotcl1.xotcl to xotcl.tcl +- rename predefined.xotcl to .tcl +- migrate further test from .xotcl to .tcl (based on next instead of xotcl) +- check ::xotcl references in serializer +- change "require xotcl::test" to "... nx::test" - copy decls for objectMethod and classMethod as comments to xotcl.c, fix and check order Index: apps/scripts/soccerClub2.tcl =================================================================== diff -u --- apps/scripts/soccerClub2.tcl (revision 0) +++ apps/scripts/soccerClub2.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,210 @@ +# This is a simple introductory example for the language XOTcl. +# It demonstrates the basic language constructs on the example of +# a soccer club. + +package require next +namespace import ::nx::* + +# All the characters in this example are fictitious, and any +# resemblance to actual persons, living or deceased, is coincidental. + +# In XOTcl we do not have to provide the above file description +# as a comment, but we can use the @ object, which is used generally +# to provide any kind of information, metadata, and documentation on +# a running program. Here, we just give a file description. +# Now makeDoc.xotcl will automatically document this file for us. +@ @File { + description { + This is a simple introductory example for the language XOTcl. + It demonstrates the basic language constructs on the example of + a soccer club. + } +} + +# +# All things and entities in XOTcl are objects, a special kind of objects +# are classes. These define common properties for other objects. For a +# soccer club, we firstly require a common class for all kinds of members. +# +# Common to all members is that they have a name. Common properties defined +# across all instances of a class are called "Parameters" in XOTcl. +# +Class create ClubMember -parameter {{name ""}} + +# A special club member is a Player. Derived classes can be build with +# inheritance (specified through 'superclass'). Players may have a +# playerRole (defaults to NONE): +Class create Player -superclass ClubMember -parameter {{playerRole NONE}} + +# other club member types are trainers, player-trainers, and presidents +Class create Trainer -superclass ClubMember +Class create President -superclass ClubMember + +# the PlayerTrainer uses multiple inheritance by being both a player +# and a trainer +Class create PlayerTrainer -superclass {Player Trainer} + +# +# Now we define the SoccerTeam class. +# +Class create SoccerTeam -parameter {name location type} + +# We may add a player. This is done by a method. Instance methods are +# in XOTcl defined with 'method'. All club members are aggregated in +# the team (denoted by :: namespace syntax). +SoccerTeam method newPlayer args { + # we use a unique autoname for the object to prevent name + # collisions, like ::player01, ::player02, ... + eval Player new -childof [self] $args +} + +# A player can be transfered to another team. The player object does +# not change internally (e.g. the playerRole stays the same). Therefore we +# 'move' it to the destination team. +SoccerTeam method transferPlayer {playername destinationTeam} { + # We use the aggregation introspection option 'children' in order + # to get all club members + foreach player [.info children] { + # But we only remove matching playernames of type "Player". We do + # not want to remove another club member type who has the same + # name. + if {[$player info is type Player] && [$player name] eq $playername} { + # We simply 'move' the player object to the destination team. + # Again we use a unique autoname in the new scope + $player move ${destinationTeam}::[$destinationTeam autoname player%02d] + } + } +} + +# Finally we define two convenience methods to print the members/players to +# stdout with puts. +SoccerTeam method printMembers {} { + puts "Members of ${.name}:" + foreach m [.info children] {puts " [$m name]"} +} +SoccerTeam method printPlayers {} { + puts "Players of ${.name}:" + foreach m [.info children] { + if {[$m info is type Player]} {puts " [$m name]"} + } +} + +# Now let us build to example soccer team objects. +SoccerTeam create lyon -name "Olympique Lyon" -location "Lyon" +SoccerTeam create bayernMunich -name "F.C. Bayern München" -location "Munich" + +# With 'addPlayer' we can create new aggregated player objects +# +# Let us start some years in the past, when "Franz Beckenbauer" was +# still a player. +set fb [bayernMunich newPlayer -name "Franz Beckenbauer" \ + -playerRole PLAYER] + +# 'playerRole' may not take any value. It may either be NONE, PLAYER, +# or GOALY ... such rules may be given as assertions (here: an instinvar +# gives an invariant covering all instances of a class). In XOTcl +# the rules are syntactically identical to 'if' statements +Player instinvar { + {${.playerRole} in [list "NONE" "PLAYER" "GOALY"]} +} + +# If we break the invariant and turn assertions checking on, we should +# get an error message: +$fb check all +if {[catch {$fb playerRole SINGER} errMsg]} { + puts "CAUGHT EXCEPTION: playerRole has either to be NONE, PLAYER, or TRAINER" + # turn assertion checking off again and reset to PLAYER + $fb check {} + $fb playerRole PLAYER +} + +# But soccer players may play quite different, orthogonal +# roles. E.g. Franz Beckenbauer was also a singer (a remarkably bad +# one). However, we can not simply add such orthogonal, extrinsic +# extensions with multiple inheritance or delegation. Otherwise we +# would have either to build a lot of unnecessary helper classes, like +# PlayerSinger, PlayerTrainerSinger, etc., or we would have to build +# such helper objects. This either leads to an unwanted combinatorial +# explosion of class or object number. +# +# Here we can use a per-object mixin, which is a language construct +# that expresses that a class is used as a role or as an extrinsic +# extension to an object. + +# First we just define the Singer class. +Class create Singer { + .method sing text { + puts "${.name} sings: $text, lala." + } +} + +# Now we register this class as a per-object mixin on the player object: +$fb mixin Singer + +# And now Franz Beckenbauer is able to sing: +$fb sing "lali" + +# But Franz Beckenbauer has already retired. When a player retires, we +# have an intrinsic change of the classification. He *is* not a player +# anymore. But still he has the same name, is club member, and +# is a singer (brrrrrr). + +# Before we perform the class change, we extend the Player class to +# support it. I.e. the playerRole is not valid after class change +# anymore (we unset the instance variable). +Player method class args { + unset .playerRole + next +} + +# Now we can re-class the player object to its new class (now Franz +# Beckenbauer is President of Bayern Munich. +$fb class President +# Check that the playerRole isn't there anymore. +if {[catch {$fb playerRole} errMsg]} { + puts "CAUGHT EXCEPTION: The player role doesn't exist anymore (as it should be after the class change)" +} + +# But still Franz Beckenbauer can entertain us with what he believes +# is singing: +$fb sing "lali" + +# Now we define some new players for Bayern Munich: +bayernMunich newPlayer -name "Oliver Kahn" -playerRole GOALY +bayernMunich newPlayer -name "Giovanne Elber" -playerRole PLAYER + +# if we enlist the players of Munich Franz Beckenbauer is not enlisted +# anymore: +bayernMunich printPlayers + +# But as a president he still appears in the list of members: +bayernMunich printMembers + +# Now consider an orthonogal extension of a transfer list. Every +# transfer in the system should be notified. But since the transfer +# list is orthogonal to SoccerTeams we do not want to interfere with +# the existing implementation at all. Moreover, the targeted kind of +# extension has also to work on all subclasses of SoccerTeam. Firstly, we +# just create the extension as an ordinary class: +Class create TransferObserver { + .method transferPlayer {pname destinationTeam} { + puts "Player '$pname' is transfered to Team '[$destinationTeam name]'" + next + } +} + +# Now we can apply the class as a per-class mixin, which functions +# exactly like a per-object mixin, but on all instances of a class and +# its subclasses. The 'next' primitive ensures that the original +# method on 'SoccerTeam' is called after notifying the transfer (with +# puts to stdout) +SoccerTeam mixin TransferObserver + +# If we perform a transfer of one of the players, he is moved to the new +# club and the transfer is reported to the stdout: + +bayernMunich transferPlayer "Giovanne Elber" lyon + +# Finally we verify the transfer by printing the players: +lyon printPlayers +bayernMunich printPlayers Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `apps/scripts/soccerClub2.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: doc/index.html =================================================================== diff -u -r224d1a24b787b67fb9f0ff8a894f3092e8e4d5ae -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- doc/index.html (.../index.html) (revision 224d1a24b787b67fb9f0ff8a894f3092e8e4d5ae) +++ doc/index.html (.../index.html) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -23,7 +23,7 @@

Index: generic/predefined.h =================================================================== diff -u -ra98ffcaf356b6d0a1e9d58ae7d0835ed11f56fa3 -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- generic/predefined.h (.../predefined.h) (revision a98ffcaf356b6d0a1e9d58ae7d0835ed11f56fa3) +++ generic/predefined.h (.../predefined.h) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -600,17 +600,7 @@ "if {[file isdirectory $d] && [file writable $d]} {\n" "return $d}}}\n" "return /tmp}\n" -"proc use {version} {\n" -"set callingNs [uplevel {namespace current}]\n" -"switch -exact $version {\n" -"xotcl -\n" -"xotcl1 {\n" -"package require XOTcl\n" -"if {$callingNs ne \"::xotcl\"} {uplevel {namespace import -force ::xotcl::*}}}\n" -"default {\n" -"if {$callingNs ne \"::xotcl\"} {uplevel {namespace import -force ::xotcl::*}}\n" -"if {$callingNs ne \"::next\"} {uplevel {namespace import -force ::nx::*}}}}}\n" -"namespace export tmpdir use}\n" +"namespace export tmpdir}\n" "namespace eval ::nx {\n" "namespace export Attribute current\n" "if {![info exists ::env(HOME)]} {set ::env(HOME) /root}\n" Index: generic/predefined.xotcl =================================================================== diff -u -ra98ffcaf356b6d0a1e9d58ae7d0835ed11f56fa3 -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- generic/predefined.xotcl (.../predefined.xotcl) (revision a98ffcaf356b6d0a1e9d58ae7d0835ed11f56fa3) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -1418,23 +1418,7 @@ return /tmp } - proc use {version} { - set callingNs [uplevel {namespace current}] - switch -exact $version { - xotcl - - xotcl1 { - package require XOTcl - #puts stderr "current=[namespace current], ul=[uplevel {namespace current}]" - if {$callingNs ne "::xotcl"} {uplevel {namespace import -force ::xotcl::*}} - } - default { - if {$callingNs ne "::xotcl"} {uplevel {namespace import -force ::xotcl::*}} - if {$callingNs ne "::next"} {uplevel {namespace import -force ::nx::*}} - } - } - } - - namespace export tmpdir use + namespace export tmpdir } ####################################################################### Index: library/lib/make.tcl =================================================================== diff -u --- library/lib/make.tcl (revision 0) +++ library/lib/make.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,172 @@ +### inEachDir changes now to each directory +### install clears tgarget directory before installing +### Object file added (for better -n processing) +lappend auto_path .. + +package require next +namespace import -force ::nx::* + +### +Object create make { + # + # shared lib add files for pkgIndex.tcl + # + :method mkIndex {name} { + #puts stderr "+++ mkIndex in [pwd]" + set fls {} + foreach f [glob -nocomplain *tcl] { + if {![file isdirectory $f]} { + set F [open $f]; set c [read $F]; close $F + if {[string match "*package provide*" $c]} { lappend fls $f } + } + } + + set so [glob -nocomplain *[info sharedlibextension]] + set version $::nx::core::version + # loading libnext into nextsh might cause problems on some systems + foreach lib [list libnext$version[info sharedlibextension] \ + next$version.dll] { + set p [lsearch -exact $so $lib] + if {$p != -1} { + set so [lreplace $so $p $p] + #puts stderr "new so=<$so>" + } + } + #puts stderr "[pwd]: call so=<$so>" + set fls [concat $fls $so] + + if {$fls ne ""} { + if {[file exists pkgIndex.tcl]} { + file delete -force pkgIndex.tcl + } + #puts stderr "callinglevel <[self callinglevel]> $fls" + #puts stderr "[pwd]:\n\tcall eval pkg_mkIndex -verbose -direct . $fls" + if {[catch {pkg_mkIndex -verbose -direct . {*}$fls} errs]} { + puts stderr "!!! $errs" + } + #puts stderr "[pwd] done" + } + + foreach addFile [glob -nocomplain *.add] { + if {[file exists $addFile]} { + puts stderr "Appending $addFile to pkgIndex.tcl in [pwd]" + set OUT [file open pkgIndex.tcl a] + set IN [file open $addFile] + puts -nonewline $OUT [read $IN] + close $IN; close $OUT + } + } + #puts stderr "+++ mkIndex name=$name, pwd=[pwd] DONE" + } + + :method inEachDir {path cmd} { + #puts stderr "[pwd] inEachDir $path [file isdirectory $path]" + if { [file isdirectory $path] + && ![string match *CVS $path] + && ![string match *SCCS $path] + && ![string match *Attic $path] + && ![string match *dbm* $path] + } { + set olddir [pwd] + cd $path + make {*}$cmd $path + set files [glob -nocomplain *] + cd $olddir + foreach p $files { :inEachDir $path/$p $cmd } + #puts stderr "+++ change back to $olddir" + } + } + + :method in {path cmd} { + if {[file isdirectory $path] && ![string match *CVS $path]} { + set olddir [pwd] + cd $path + make {*}$cmd $path + cd $olddir + } + } +} + +### tcl file-command +rename file tcl_file +Object create file { + :requireNamespace + + array set :destructive { + atime 0 attributes 0 copy 1 delete 1 dirname 0 + executable 0 exists 0 extension 0 isdirectory 0 isfile 0 + join 0 lstat 0 mkdir 1 mtime 0 nativename 0 + owned 0 pathtype 0 readable 0 readlink 0 rename 1 + rootname 0 size 0 split 0 stat 0 tail 0 + type 0 volumes 0 writable 0 + } + + foreach subcmd [array names :destructive] { + :method $subcmd args { + #puts stderr " [pwd] call: '::tcl_file [self proc] $args'" + ::tcl_file [self proc] {*}$args + } + } +} + +rename open file::open +proc open {f {mode r}} { file open $f $mode } + + +### minus n option +Class create make::-n +foreach f [file info methods] { + if {$f eq "unknown" || $f eq "next" || $f eq "self"} continue + if {![file exists destructive($f)] || [file eval [list set :destructive($f)]]} { + #puts stderr destruct=$f + make::-n method $f args { + puts "--- [pwd]:\t[self proc] $args" + } + } else { + #puts stderr nondestruct=$f + make::-n method $f args { + set r [next] + #puts "??? [self proc] $args -> {$r}" + return $r + } + } +} + +### command line parameters +if {![info exists argv] || $argv eq ""} {set argv -all} +if {$argv eq "-n"} {set argv "-n -all"} + +Class create Script { + :object method create args { + lappend args {*}$::argv + set s [next] + set method [list] + foreach arg [lrange $args 1 end] { + switch -glob -- $arg { + "-all" {$s all} + "-n" {$s n} + "-*" {set method [string range $arg 1 end]} + default {$s $method $arg} + } + } + } + + :method unknown args { + puts stderr "$::argv0: Unknown option ´-$args´ provided" + } + + :method n {} {file mixin make::-n} + + :method all {} {make inEachDir . mkIndex} + + :method dir {dirName} {cd $dirName} + + :method target {path} {make eval [list set :target $path]} + + :create main +} + +#puts stderr "+++ make.xotcl finished." +#if {[set ::tcl_platform(platform)] eq "windows"} { +# exit +#} Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `library/lib/make.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: library/lib/pkgIndex.tcl =================================================================== diff -u -r3142818cb17b21de68aa1898a4a5e25f4c13f921 -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 3142818cb17b21de68aa1898a4a5e25f4c13f921) +++ library/lib/pkgIndex.tcl (.../pkgIndex.tcl) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -16,7 +16,7 @@ package ifneeded xotcl::package 0.91 [list source [file join $dir package.xotcl]] package ifneeded xotcl::script 0.9 [list source [file join $dir Script.xotcl]] package ifneeded xotcl::staticMetadataAnalyzer 0.84 [list source [file join $dir staticMetadata.xotcl]] -package ifneeded xotcl::test 2.0 [list source [file join $dir test.xotcl]] +package ifneeded xotcl::test 2.0 [list source [file join $dir test.tcl]] package ifneeded xotcl::trace 0.91 [list source [file join $dir trace.xotcl]] package ifneeded xotcl::upvar-compat 1.0 [list source [file join $dir upvarcompat.xotcl]] package ifneeded xotcl::wafecompat 0.9 [list source [file join $dir wafecompat.tcl]] Index: library/lib/test.tcl =================================================================== diff -u --- library/lib/test.tcl (revision 0) +++ library/lib/test.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,152 @@ +package provide xotcl::test 2.0 +package require next + +namespace eval ::nx::test { + namespace import ::nx::* + + # @file Simple regression test support. + + Class create Test { + # + # Class Test is used to configure test instances, which can + # be configured by the following parameters: + # + # @param cmd the command to be executed + # @param expected the expected result + # @param count number of executions of cmd + # @param pre a command to be executed at the begin of the test (before cmd) + # @param post a command to be executed after the test (after all cmds) + # @param namespace in which pre, post and cmd are evaluated; default "::" + # + # The defined tests can be executed by [:cmd "Test run"] + + :attribute {name ""} + :attribute cmd + :attribute {namespace ::} + :attribute {verbose 0} + :attribute {expected 1} + :attribute {count 100} + :attribute msg + :attribute setResult + :attribute errorReport + :attribute pre + :attribute post + + set :count 0 + + :public object method case {name arg:optional} { + # + # Experimental version of Test case, which (1) accepts test case as argument + # and (2) destroys all created objects on exit (auto cleanup) + # + # General limitation: namespace resolving differs in nested evals + # from global evals. So, this approach is not suitable for all test + # (but for most). + # + # Current limitations: just for xotcl2, no method/mixin cleanup/var cleanup + # + set :case $name + if {[info exists arg]} { + foreach o [Object info instances -closure] {set pre_exist($o) 1} + namespace eval :: [list [self] eval $arg] + #:eval $arg + foreach o [Object info instances -closure] { + if {[info exists pre_exist($o)]} continue + #puts "must destroy $o" + if {[::nx::core::objectproperty $o object]} {$o destroy} + } + } + } + + :public object method parameter {name value:optional} { + if {[info exists value]} { + #[[self] slot $name] default $value + [self] slot $name default $value + :__invalidateobjectparameter + } else { + return [[self] slot $name default] + } + } + + :public object method new args { + if {[info exists :case]} { + if {![info exists :ccount(${:case})]} {set :ccount(${:case}) 0} + set :name ${:case}.[format %.3d [incr :ccount(${:case})]] + } else { + set :name t.[format %.3d [incr :count]] + } + eval :create ${:name} -name ${:name} $args + } + + :public object method run {} { + set startTime [clock clicks -milliseconds] + foreach example [lsort [:info instances -closure]] { + $example run + } + puts stderr "Total Time: [expr {[clock clicks -milliseconds]-$startTime}] ms" + } + + :public method call {msg cmd} { + if {[:verbose]} {puts stderr "$msg: $cmd"} + #if {[catch {::namespace eval ${:namespace} $cmd} result]} { + #puts stderr ERROR=$result + #} + #puts stderr "$msg: $cmd => $result" + #return $result + return [::namespace eval ${:namespace} $cmd] + } + + :public method run args { + if {[info exists :pre]} {:call "pre" ${:pre}} + if {![info exists :msg]} {set :msg ${:cmd}} + set gotError [catch {:call "run" ${:cmd}} r] + if {[info exists :setResult]} {set r [eval [set :setResult]]} + if {$r eq ${:expected}} { + if {$gotError} { + set c 1 + } else { + if {[info exists :count]} {set c ${:count}} {set c 1000} + } + if {[:verbose]} { + puts stderr "running test $c times" + } + if {$c > 1} { + #set r0 [time ${:cmd} $c] + #puts stderr "time {time ${:cmd} $c}" + set r1 [time {time {::namespace eval ${:namespace} ${:cmd}} $c}] + #regexp {^(-?[0-9]+) +} $r0 _ mS0 + regexp {^(-?[0-9]+) +} $r1 _ mS1 + set ms [expr {$mS1*1.0/$c}] + puts stderr "[set :name]:\t[format %6.2f $ms] mms, ${:msg}" + } else { + puts stderr "[set :name]: ${:msg} ok" + } + } else { + puts stderr "[set :name]:\tincorrect result for '${:msg}'" + puts stderr "\texpected: '${:expected}', got '$r' [info exists :errorReport]" + puts stderr "\tin test file [info script]" + if {[info exists :errorReport]} {eval [set :errorReport]} + exit -1 + } + if {[info exists :post]} {:call "post" ${:post}} + } + + } + ::namespace export Test +} + +proc ? {cmd expected {msg ""}} { + set namespace [uplevel {::namespace current}] + if {[string match ::xotcl* $namespace]} {set namespace ::} + #puts stderr "eval in namespace $namespace" + if {$msg ne ""} { + set t [Test new -cmd $cmd -msg $msg -namespace $namespace] + } else { + set t [Test new -cmd $cmd -namespace $namespace] + } + $t expected $expected + $t run +} + + +namespace import ::nx::test::* Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `library/lib/test.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: library/serialize/Serializer.xotcl =================================================================== diff -u -rdaafc0f0261f6b47a01c7cc8975acdd66f91f360 -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision daafc0f0261f6b47a01c7cc8975acdd66f91f360) +++ library/serialize/Serializer.xotcl (.../Serializer.xotcl) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -9,7 +9,7 @@ # package (when ::xotcl::Object is defined), and (b) load it from # "xotcl1.tcl", when the serializer is alreaded loaded. -namespace eval ::xotcl::serializer { +namespace eval ::nx::serializer { namespace import ::nx::* Index: tests/aliastest.tcl =================================================================== diff -u --- tests/aliastest.tcl (revision 0) +++ tests/aliastest.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,381 @@ +package require next; namespace import -force ::nx::* +package require xotcl::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 alias get ::nx::core::setvar" + + # define an alias and retrieve its definition + set cmd "::nx::Object alias -objscope set ::set" + eval $cmd + ? {Object info method definition set} $cmd + +} + +Test case alias-simple { + # define an alias and retrieve its definition + Class create Base { + :method foo {{-x 1}} {return $x} + } + + Class create Foo + ::nx::core::alias ::Foo foo ::nx::core::classes::Base::foo + + ? {Foo info method definition foo} "::Foo alias foo ::nx::core::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 method foo {} {} + ? {Foo info methods -methodtype alias} "" + ? {Base info methods -methodtype scripted} {} + ? {Foo info methods -methodtype scripted} {} + ? {Foo info method definition foo} "" + + + Base method foo {{-x 1}} {return $x} + ::nx::core::alias ::Foo foo ::nx::core::classes::Base::foo + + ? {Base info methods -methodtype scripted} {foo} "defined again" + ? {Foo info methods -methodtype alias} {foo} "aliased again" + Foo 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 method foo args { return [self class]->[self proc] } + ::nx::core::alias T FOO ::nx::core::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 method foo args { return [self class]->[self proc] } + ::nx::core::alias T FOO ::nx::core::classes::T::foo + ::nx::core::alias S BAR ::nx::core::classes::T::FOO + + ? {T info methods -methodtype alias} "FOO" + ? {T info method definition FOO} "::T alias FOO ::nx::core::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 alias BAR ::nx::core::classes::T::FOO" + + + T method foo {} {} + ? {T info methods} {} + ? {S info methods} {} + + T method foo args { return [self class]->[self proc] } + ::nx::core::alias T FOO ::nx::core::classes::T::foo + ::nx::core::alias S BAR ::nx::core::classes::T::FOO + + ? {lsort [T info methods]} {FOO foo} + ? {S info methods} {BAR} + T method foo {} {} + ? {S info methods} {} + ? {T info methods} {} + + T method foo args { return [self class]->[self proc] } + T object method bar args { return [self class]->[self proc] } + ::nx::core::alias T -per-object FOO ::nx::core::classes::T::foo + ::nx::core::alias T -per-object BAR ::T::FOO + ::nx::core::alias T -per-object ZAP ::T::BAR + ? {T info methods} {foo} + ? {lsort [T object info methods -methodtype alias]} {BAR FOO ZAP} + ? {lsort [T object info methods]} {BAR FOO ZAP bar} + ? {t foo} ::T->foo + ? {T object info method definition ZAP} {::T object alias ZAP ::T::BAR} + + ? {T FOO} ->foo + ? {T BAR} ->foo + ? {T ZAP} ->foo + ? {T bar} ->bar + T object method FOO {} {} + ? {T info methods} {foo} + ? {lsort [T object info methods]} {BAR ZAP bar} + ? {T BAR} ->foo + ? {T ZAP} ->foo + rename ::T::BAR "" + ? {T info methods} {foo} + ? {lsort [T 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 object method BAR {} {} + ? {T info methods} {foo} + ? {lsort [T object info methods]} {ZAP bar} + ? {T ZAP} ->foo + T method foo {} {} + ? {T info methods} {} + ? {lsort [T object info methods]} {bar} +} + +Test case alias-per-object { + + Class create T { + :object method bar args { return [self class]->[self proc] } + :create t + } + proc ::foo args { return [self class]->[self proc] } + + # + # per-object methods as per-object aliases + # + T object method m1 args { return [self class]->[self proc] } + ::nx::core::alias T -per-object M1 ::T::m1 + ::nx::core::alias T -per-object M11 ::T::M1 + ? {lsort [T object info methods]} {M1 M11 bar m1} + ? {T m1} ->m1 + ? {T M1} ->m1 + ? {T M11} ->m1 + T object method M1 {} {} + ? {lsort [T object info methods]} {M11 bar m1} + ? {T m1} ->m1 + ? {T M11} ->m1 + T object method m1 {} {} + ? {lsort [T object info methods]} {bar} + + # + # a proc as alias + # + + proc foo args { return [self class]->[self proc] } + ::nx::core::alias T FOO1 ::foo + ::nx::core::alias T -per-object FOO2 ::foo + # + # ! per-object alias referenced as per-class alias ! + # + ::nx::core::alias T BAR ::T::FOO2 + ? {lsort [T 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 object info methods]} {bar} + ? {lsort [T info methods]} {} +} + + +# namespaced procs + namespace deletion +Test case alias-namespaced { + Class create T { + :object method bar args { return [self class]->[self proc] } + :create t + } + + namespace eval ::ns1 { + proc foo args { return [self class]->[self proc] } + proc bar args { return [uplevel 2 {set _}] } + proc bar2 args { upvar 2 _ __; return $__} + } + + ::nx::core::alias T FOO ::ns1::foo + ::nx::core::alias T BAR ::ns1::bar + ::nx::core::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 object method zap args { return [self class]->[self proc] } + ::nx::core::alias ::U -per-object ZAP ::U::zap + U requireNamespace + ? {namespace exists ::U} 1 + + U object method bar args { return [self class]->[self proc] } + ::nx::core::alias U -per-object BAR ::U::bar + ? {lsort [U object info methods]} {BAR ZAP bar zap} + ? {U BAR} ->bar + ? {U ZAP} ->zap + namespace delete ::U + ? {namespace exists ::U} 0 + ? {lsort [U object info methods]} {} + ? {U info callable BAR} "" + ? {U info callable ZAP} "" + + ::U destroy +} + +# dot-resolver/ dot-dispatcher used in aliased proc + +Test case alias-dot-resolver { + + Class create V { + set :z 1 + :method bar {z} { return $z } + :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]] } + + ::nx::core::alias V FOO1 ::foo + ::nx::core::alias V -per-object FOO2 ::foo + + ? {lsort [V object info methods]} {FOO2 bar} + ? {lsort [V info methods]} {FOO1 bar} + + ? {V FOO2} 1-1-1 + ? {v FOO1} 2-2-2 + V method FOO1 {} {} + ? {lsort [V info methods]} {bar} + rename ::foo "" + ? {lsort [V object info methods]} {bar} +} + +# +# Tests for the ::nx::core::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 ::nx::core::alias store: +# ,, -> +# + +Object create o +Class create C + +o method bar args {;} + +? {info vars ::nx::core::alias} ::nx::core::alias +? {array exists ::nx::core::alias} 1 + +proc ::foo args {;} +::nx::core::alias ::o FOO ::foo +::nx::core::alias ::C FOO ::foo +? {info exists ::nx::core::alias(::o,FOO,1)} 1 +? {info exists ::nx::core::alias(::C,FOO,0)} 1 +? {array get ::nx::core::alias ::o,FOO,1} "::o,FOO,1 ::foo" +? {array get ::nx::core::alias ::C,FOO,0} "::C,FOO,0 ::foo" +? {o info method definition FOO} "::o alias FOO ::foo" +? {C info method definition FOO} "::C alias FOO ::foo" + +::nx::core::alias o FOO ::o::bar +? {info exists ::nx::core::alias(::o,FOO,1)} 1 +? {array get ::nx::core::alias ::o,FOO,1} "::o,FOO,1 ::o::bar" +? {o info method definition FOO} "::o alias FOO ::o::bar" + +# AliasDelete in XOTclRemoveObjectMethod +o method FOO {} {} +? {info exists ::nx::core::alias(::o,FOO,1)} 0 +? {array get ::nx::core::alias ::o,FOO,1} "" +? {o info method definition FOO} "" + +# AliasDelete in XOTclRemoveClassMethod +C method FOO {} {} +? {info exists ::nx::core::alias(::C,FOO,0)} 0 +? {array get ::nx::core::alias ::C,FOO,0} "" +? {C info method definition FOO} "" + +::nx::core::alias ::o BAR ::foo +::nx::core::alias ::C BAR ::foo + +# AliasDelete in XOTclAddObjectMethod +? {info exists ::nx::core::alias(::o,BAR,1)} 1 +::o method BAR {} {;} +? {info exists ::nx::core::alias(::o,BAR,1)} 0 + +# AliasDelete in XOTclAddInstanceMethod +? {info exists ::nx::core::alias(::C,BAR,0)} 1 +::C method BAR {} {;} +? {info exists ::nx::core::alias(::C,BAR,0)} 0 + +# AliasDelete in aliasCmdDeleteProc +::nx::core::alias o FOO ::foo +? {info exists ::nx::core::alias(::o,FOO,1)} 1 +rename ::foo "" +? {info exists ::nx::core::alias(::o,FOO,1)} 0 + +::nx::core::alias o FOO ::o::bar +::nx::core::alias o BAR ::o::FOO +? {info exists ::nx::core::alias(::o,FOO,1)} 1 +? {info exists ::nx::core::alias(::o,BAR,1)} 1 +o method bar {} {} +? {info exists ::nx::core::alias(::o,FOO,1)} 0 +? {info exists ::nx::core::alias(::o,BAR,1)} 0 + +# +# pulling the rug out from the proc-alias deletion mechanism +# + +proc ::foo args {;} +::nx::core::alias C FOO ::foo +? {info exists ::nx::core::alias(::C,FOO,0)} 1 +unset ::nx::core::alias(::C,FOO,0) +? {info exists ::nx::core::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 ::nx::core::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 ::nx::core::alias upon "info method definition" calls? is this feasible, +# e.g. through rename traces? +# + +C create c +proc ::foo args { return [self]->[self proc]} +? {info exists ::nx::core::alias(::C,FOO,0)} 0 +::nx::core::alias C FOO ::foo +? {info exists ::nx::core::alias(::C,FOO,0)} 1 +? {C info methods -methodtype alias} FOO +rename ::foo ::foo2 +? {info exists ::nx::core::alias(::C,FOO,0)} 1 +? {C info methods -methodtype alias} FOO +? {c FOO} ::c->foo2 +? {C info method definition FOO} "::C alias FOO ::foo"; # should be ::foo2 (!) Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `tests/aliastest.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/destroytest.tcl =================================================================== diff -u --- tests/destroytest.tcl (revision 0) +++ tests/destroytest.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,591 @@ +package require next; namespace import ::nx::* +package require xotcl::test + +Test parameter count 10 + +::nx::core::alias ::nx::Object set -objscope ::set + +Class create O -superclass Object { + :method init {} { + set ::ObjectDestroy 0 + set ::firstDestroy 0 + } + :method destroy {} { + incr ::ObjectDestroy + #[:info class] dealloc [self] + 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 " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + :destroy + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + ? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBBB" + ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +? {::nx::core::objectproperty c1 object} 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 " *** [self] destroy block"} +C method foo {} { + puts stderr "==== $::case [self]" + :destroy + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + ? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBBB" + ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +? {::nx::core::objectproperty c1 object} 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 " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + [:info class] create [self] + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + ? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBBB" + ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +? {::nx::core::objectproperty c1 object} 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 " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + rename [self] "" + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + ? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBB" + ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +? {::nx::core::objectproperty c1 object} 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 " *** [self] destroy block"} +C method foo {} { + puts stderr "==== $::case [self]" + rename [self] "" + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + ? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBB" + ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +puts stderr ======[c1 set x] +? {::nx::core::objectproperty c1 object} 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 self" +Test case rename-to-self +Object create o +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + rename o [self] + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + ? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBB" + ? {::nx::core::objectproperty c1 object} 1 "$::case object still exists in proc" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +? {::nx::core::objectproperty c1 object} 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 self" +Test case rename-proc-to-self +proc o args {} +Class create C -superclass O +C method destroy {} {incr ::firstDestroy; puts stderr " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + set x [catch {rename o [self]}] + ? "set _ $x" 1 "$::case tcl refuses to rename into an existing command" +} +C create c1 +c1 foo +? {::nx::core::objectproperty c1 object} 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 " *** [self] destroy"; next} + C method foo {} { + puts stderr "==== $::case [self]" + namespace delete ::test + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + # + # If the following line is commented in, the namespace is deleted + # here. Is there a bug with nsPtr->activationCount + # + #? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBB" + puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" + ? "::nx::core::objectproperty [self] object" 0 ;# WHY? + puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "$::case destroy not yet called" + } +} +test::C create test::c1 +test::c1 foo +puts stderr ======[::nx::core::objectproperty test::c1 object] +? {::nx::core::objectproperty test::c1 object} 0 "object still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "destroy was called when poping stack frame" +? {::nx::core::objectproperty ::test::C object} 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 " *** [self] destroy block"} + C method foo {} { + puts stderr "==== $::case [self]" + namespace delete ::test + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + # + # If the following line is commented in, the namespace is deleted + # here. Is there a bug with nsPtr->activationCount + # + #? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBBB" + puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" + ? "::nx::core::objectproperty [self] object" 0 "$::case object still exists in proc";# WHY? + puts stderr "???? [self] exists [::nx::core::objectproperty [self] object]" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called"; # NOT YET CALLED + } +} +test::C create test::c1 +test::c1 foo +puts stderr ======[::nx::core::objectproperty test::c1 object] +? {::nx::core::objectproperty test::c1 object} 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 " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + o destroy + puts stderr "AAAA" + # the following isobject call has a problem in Tcl_GetCommandFromObj(), + # which tries to access invalid memory + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + #? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBBB" + ? {::nx::core::objectproperty ::o::c1 object} 0 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" +} +C create o::c1 +o::c1 foo + +puts stderr ======[::nx::core::objectproperty ::o::c1 object] +? {::nx::core::objectproperty ::o::c1 object} 0 "$::case object o::c1 still exists after proc" +? {::nx::core::objectproperty o object} 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 " *** [self] destroy block"} +C method foo {} { + puts stderr "==== $::case [self]" + o destroy + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + #? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBB" + ? {::nx::core::objectproperty ::o::c1 object} 0 "$::case object still exists in proc" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" +} +C create o::c1 +o::c1 foo +puts stderr ======[::nx::core::objectproperty ::o::c1 object] +? {::nx::core::objectproperty ::o::c1 object} 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 " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + proc [self] {args} {puts HELLO} + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + #? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBB" + ? "set ::firstDestroy" 1 "firstDestroy called" + ? "set ::ObjectDestroy" 1 "ObjectDestroy called" + ? {::nx::core::objectproperty c1 object} 0 "$::case object still exists in proc" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +? {::nx::core::objectproperty c1 object} 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 " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + C destroy + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + #? "[self] set x" 1 "$::case can still access [self]" + puts stderr "BBB" + #? [:info class] ::xotcl::Object "object reclassed" + ? [:info class] ::C "object reclassed?" + ? "set ::firstDestroy" 0 "firstDestroy called" + ? "set ::ObjectDestroy" 0 "ObjectDestroy called" + ? {::nx::core::objectproperty c1 object} 1 "object still exists in proc" + #? {::nx::core::objectproperty ::C class} 0 "class still exists in proc" + ? {::nx::core::objectproperty ::C class} 1 "class still exists in proc" +} +C create c1 +c1 foo +puts stderr ======[::nx::core::objectproperty c1 object] +? {::nx::core::objectproperty c1 object} 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 " *** [self] destroy"; next} +C method foo {} { + puts stderr "==== $::case [self]" + C destroy + puts stderr "AAAA [self] exists [::nx::core::objectproperty [self] object]" + :set x 1 + #? "[self] set x" 1 "$::case can still access [self]" + 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" + ? {::nx::core::objectproperty ::C::c1 object} 1 "object still exists in proc" + ? {::nx::core::objectproperty ::C class} 1 "class still exists in proc" +} +C create ::C::c1 +C::c1 foo +#puts stderr ======[::nx::core::objectproperty ::C::c1 object] +? {::nx::core::objectproperty ::C::c1 object} 0 "object still exists after proc" +? {::nx::core::objectproperty ::C class} 0 "class still exists after proc" +? "set ::firstDestroy" 1 "firstDestroy called" +? "set ::ObjectDestroy" 1 "ObjectDestroy called" + +# +set case "nesting destroy" +Test case nesting-destroy +Object create x +Object create x::y +x destroy +? {::nx::core::objectproperty x object} 0 "parent object gone" +? {::nx::core::objectproperty x::y object} 0 "child object gone" + +set case "deleting aliased object" +Test case deleting-aliased-object +Object create o +Object create o2 +::nx::core::alias o x o2 +? {o x} ::o2 "call object via alias" +? {o x info vars} "" "call info on aliased object" +? {o2 set x 10} 10 "set variable on object" +? {o2 info vars} x "query vars" +? {o x info vars} x "query vars via alias" +? {o x set x} 10 "set var via alias" +o2 destroy +catch {o x info vars} errMsg +? {set errMsg} "Trying to dispatch deleted object via method 'x'" "1st call on deleted object" +#? {set errMsg} "::o: unable to dispatch method 'x'" "1st call on deleted object" +catch {o x info vars} errMsg +? {set errMsg} "::o: unable to dispatch method 'x'" "2nd call on deleted object" +o destroy + +set case "deleting object with alias to object" +Test case deleting-object-with-alias-to-object +Object create o +Object create o3 +::nx::core::alias o x o3 +o destroy +? {::nx::core::objectproperty o object} 0 "parent object gone" +? {::nx::core::objectproperty o3 object} 1 "aliased object still here" +o3 destroy +? {::nx::core::objectproperty o3 object} 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 +::nx::core::alias o x o3 +o::x destroy +? {::nx::core::objectproperty o3 object} 0 "aliased object destroyed" +o destroy + +set case "create an alias, and recreate obj" +Test case create-alias-and-recreate-obj +Object create o +Object create o3 +::nx::core::alias o x o3 +Object create o3 +o3 set a 13 +? {o x set a} 13 "aliased object works after recreate" +o destroy + +set case "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 +::nx::core::alias o a o3 +::nx::core::alias C b o +C create c1 +? {c1 b set B 2} 2 "call 1st level" +? {c1 b a set A 3} 3 "call 2nd level" +? {o set B} 2 "call 1st level ok" +? {o3 set A} 3 "call 2nd level ok" +o destroy +catch {c1 b} errMsg +? {set errMsg} "Trying to dispatch deleted object via method 'b'" "call via alias to deleted object" +C destroy +c1 destroy +o3 destroy + +set case "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 +::nx::core::alias o a o3 +::nx::core::alias C b o +C create c1 +C destroy +? {::nx::core::objectproperty o object} 1 "object o still here" +? {::nx::core::objectproperty o3 object} 1 "object o3 still here" +o destroy +o3 destroy +c1 destroy + + +# +# 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 + + ? {::nx::core::objectproperty ::module class} 1 + + # delete the object/class ... and namespace + ::module destroy + + ? {::nx::core::objectproperty ::module class} 0 +} + +Test case namespace-import { + + namespace eval ::module { + Class create Foo { + :create foo + } + namespace export Foo foo + } + Class create ::module { + :create mod1 + } + ? {::nx::core::objectproperty ::module::Foo class} 1 + ? {::nx::core::objectproperty ::module::foo class} 0 + ? {::nx::core::objectproperty ::module::foo object} 1 + ? {::nx::core::objectproperty ::module class} 1 + + Object create ::o { :requireNamespace } + namespace eval ::o {namespace import ::module::*} + + ? {::nx::core::objectproperty ::o::Foo class} 1 + ? {::nx::core::objectproperty ::o::foo object} 1 + + # do not destroy namespace imported objects/classes + ::o destroy + + ? {::nx::core::objectproperty ::o::Foo class} 0 + ? {::nx::core::objectproperty ::o::foo object} 0 + + ? {::nx::core::objectproperty ::module::Foo class} 1 + ? {::nx::core::objectproperty ::module::foo object} 1 + + ::module destroy +} + +puts stderr "==== EXIT ====" +exit + +TODO: +fix crashes in regression test: DONE, + -> well we can't call traceprocs on the object being destroyed; maybe call CleanupDestroyObject() ealier + move destroy logic to activationCount DONE + simplify logic (remove callIsDestroy, callstate XOTCL_CSC_CALL_IS_DESTROY, destroyedCmd on stack content) DONE + remove CallStackMarkDestroyed(), CallStackMarkUndestroyed() DONE + remove traces of rst->callIsDestroy DONE + revive tclStack (without 85) DONE + check state changes DONE + delete active class; maybe C destroy, c1 destroy (or C::c1 + C destroy) DONE + add recreate logic test case DONE + +more generic */ +XOTCLINLINE static Tcl_ObjType * +GetCmdNameType(Tcl_ObjType *cmdType) { + + MATRIX \ No newline at end of file Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `tests/destroytest.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/info-method.tcl =================================================================== diff -u --- tests/info-method.tcl (revision 0) +++ tests/info-method.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,69 @@ +package req next +package require xotcl::test + +nx::Object create o { + :alias set ::set +} + +nx::Class create C { + :method m {x} {return proc-[self proc]} + :object method mpo {} {return instproc-[self proc]} + :method m-with-assertions {} {return proc-[self proc]} -precondition 1 -postcondition 2 + + :forward addOne expr 1 + + :object forward add1 expr 1 + + :object forward fpo ::o + + :setter s + :object setter spo + + :alias a ::set + :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 callable $m]}] $m +} +? {C info method definition a} "::C alias a ::set" +? {c1 info callable -which a} "::C alias a ::set" +? {c1 info callable -which addOne} "::C forward addOne expr 1 +" +? {c1 info callable -which m} {::C method m x {return proc-[self proc]}} +? {c1 info callable -which s} "::C setter s" +c1 method foo {} {puts foo} +? {c1 info method definition foo} "::c1 method foo {} {puts foo}" +? {c1 info callable -which foo} "::c1 method foo {} {puts foo}" + +? {C info method name m} "::nx::core::classes::C::m" +? {C object info method name mpo} "::C::mpo" + +? {C info method definition m} {::C method m x {return proc-[self proc]}} +? {C info method def m} {::C method m x {return proc-[self proc]}} +? {C object info method definition mpo} {::C object method mpo {} {return instproc-[self proc]}} +? {C info method definition m-with-assertions} \ + {::C method m-with-assertions {} {return proc-[self proc]} -precondition 1 -postcondition 2} +? {C info method parameter m} {x} +? {nx::Class info method parameter method} \ + {name arguments body -precondition -postcondition} +? {nx::Object info method parameter alias} \ + {-nonleaf:switch -objscope:switch methodName cmd} +# raises currently an error +? {catch {C info method parameter a}} 1 + +? {C info method definition addOne} "::C forward addOne expr 1 +" +? {C object info method definition add1} "::C object forward add1 expr 1 +" +? {C object info method definition fpo} "::C object forward fpo ::o" + +? {C info method definition s} "::C setter s" +? {C object info method definition spo} "::C object setter spo" + +? {C info method definition a} "::C alias a ::set" +? {C object info method definition apo} "::C object alias apo ::puts" + + +? {::nx::Object info callable -application} "" +? {::nx::Class info callable -application} "" +? {lsort [C info callable -application]} "add1 apo fpo mpo spo" +? {lsort [c1 info callable -application]} "a addOne foo m m-with-assertions s" Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `tests/info-method.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/interceptor-slot.xotcl =================================================================== diff -u -r3f0573cc75724179f416942b974373e5a62ec05e -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- tests/interceptor-slot.xotcl (.../interceptor-slot.xotcl) (revision 3f0573cc75724179f416942b974373e5a62ec05e) +++ tests/interceptor-slot.xotcl (.../interceptor-slot.xotcl) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -99,6 +99,7 @@ ? {C object-mixin} "::M" puts stderr "==================== XOTcl 1" +package require XOTcl namespace import -force ::xotcl::* Class create M1 Index: tests/mixinoftest.xotcl =================================================================== diff -u -r3f0573cc75724179f416942b974373e5a62ec05e -r752365e2a4c7ef57fc487bfff9bb387e72ccf533 --- tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision 3f0573cc75724179f416942b974373e5a62ec05e) +++ tests/mixinoftest.xotcl (.../mixinoftest.xotcl) (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -477,7 +477,7 @@ #::xotcl::test::Test destroy #puts [lsort [::xotcl::Object allinstances]] -::xotcl::use xotcl2x +namespace import -force ::nx::* ########################################### # testing simple per object mixins ########################################### Index: tests/parameters.tcl =================================================================== diff -u --- tests/parameters.tcl (revision 0) +++ tests/parameters.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,987 @@ +package require next +package require xotcl::test +namespace import ::nx::* + +Test case dummy { + puts current=[::namespace current] + set o [Object create o] + puts o=$o + + ? {::nx::core::objectproperty ::o object} 1 +} +? {::nx::core::objectproperty ::o object} 0 +#exit + +####################################################### +# parametercheck +####################################################### +Test parameter count 10000 +Test case parametercheck { + + Object create o1 + Class create C -parameter {a {b:boolean} {c 1}} + C create c1 + Class create M + c1 mixin M + + ? {::nx::core::parametercheck object o1} 1 + ? {::nx::core::parametercheck integer 1} 1 + + ? {::nx::core::objectproperty o1 object} 1 + ? {::nx::core::objectproperty c1 type C} 1 + + ? {::nx::core::is c1 object -type C} 1 + ? {::nx::core::is c1 object -hasmixin M -type C} 1 + ? {::nx::core::is c1 object -hasmixin M1 -type C} 0 + ? {::nx::core::is c1 object -hasmixin M -type C0} 0 + ? {::nx::core::is o1 object} 1 + ? {::nx::core::is 1 integer} 1 + ? {::nx::core::is c1 type C} 1 + ? {::nx::core::is o type C} 0 + ? {::nx::core::is o object -type C} 0 + ? {::nx::core::is o object -hasmixin C} 0 +#exit + ? {::nx::core::parametercheck class o1} {expected class but got "o1" for parameter value} + ? {::nx::core::parametercheck -nocomplain class o1} 0 + ? {::nx::core::parametercheck class Test} 1 + ? {::nx::core::parametercheck object,multivalued [list o1 Test]} 1 + + ? {::nx::core::parametercheck integer,multivalued [list 1 2 3]} 1 + ? {::nx::core::parametercheck integer,multivalued [list 1 2 3 a]} \ + {invalid value in "1 2 3 a": expected integer but got "a" for parameter value} + ? {::nx::core::parametercheck object,type=::C c1} 1 + ? {::nx::core::parametercheck object,type=::C o} \ + {expected object but got "o" for parameter value} \ + "object, but different type" + ? {::nx::core::parametercheck object,type=::C c} \ + {expected object but got "c" for parameter value} \ + "no object" + ? {::nx::core::parametercheck object,type=::nx::Object c1} 1 "general type" + + # do not allow "currently unknown" user defined types in parametercheck + ? {::nx::core::parametercheck in1 aaa} {invalid value constraints "in1"} + + ? {::nx::core::parametercheck lower c} 1 "lower case char" + ? {::nx::core::parametercheck lower abc} 1 "lower case chars" + ? {::nx::core::parametercheck lower Abc} {expected lower but got "Abc" for parameter value} + ? {string is lower abc} 1 "tcl command 'string is lower'" + + ? {::nx::core::parametercheck {i:integer 1} 2} {invalid value constraints "i:integer 1"} +} + +####################################################### +# parametercheck +####################################################### +Test parameter count 10000 +Test case parametercheck { + + Object create ::paramManager { + :method type=sex {name value} { + return "agamous" + } + } + + ? {::nx::core::parametercheck 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} +# initcmd +# valuecmd +# valuechangedcmd +# arg +# } -- typical object parameters +# +# MethodParameterSlot -parameter {type required multivalued noarg arg} +# -- typical method parameters + + +####################################################### +# objectparameter +####################################################### +Test parameter count 10 +Test case objectparameter { + + Class create C -parameter {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 -parameter: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,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 -parameter {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,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 -parameter {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,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 -parameter {a {b:boolean} {c 1}} + Class create D -superclass C -parameter {d:required} + D create d1 -d 100 + + Class create M -parameter {m1 m2 b} + Class create M2 -parameter {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,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,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,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,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,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 -parameter {a {b:boolean} {c 1}} + Class create D -superclass C -parameter {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 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 method foo {a:relation} {}} \ + {Parameter option 'relation' not allowed} \ + "don't allow relation option as method parameter" + + ? {D method foo {a:double} {return $a}} \ + {::nx::core::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 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 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 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 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 -parameter { + {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 + + :method bar { + {-s:substdefault "[self]"} + {-literal "[self]"} + {-c:substdefault "[my c]"} + {-d:integer,substdefault "$d"} + } { + return $s-$literal-$c-$d + } + } + + ? {d1 bar -c 1} {::d1-[self]-1-2} "substdefault in method parameter" + + Class create Bar -superclass D -parameter { + {s "[self]"} + {literal "\\[self\\]"} + {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-[self]-::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-[self]-::Bar-literal $d-1} \ + "substdefault and switch in object parameter 2" + + # Observations: + # 1) syntax for "-parameter" 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 -parameter 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 -parameter defaults does not make much sense. + # deactivated for now; otherwise we would need "\\" + + D method bar { + {-s:substdefault "[self]"} + {-literal "[self]"} + {-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 "[self]"} {-literal "[self]"} {-c:substdefault "[my c]"} {-d:integer,substdefault "$d"} -switch:switch -optflag x y:integer {z 1}} \ + "query method parameter" + + D method foo {a b {-c 1} {-d} x {-end 100}} { + set result [list] + foreach v [[self class] info method args [self proc]] { + 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 method foo {a b c {end 100}} { + set result [list] + foreach v [[self class] info method args [self proc]] { + 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'" + + ? {catch {Object info method parameter forward}} \ + "1" \ + "query parameter for C-defined method 'forward'" + + ? {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 -parameter 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 method foo {a:mytype} { + puts stderr 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 method foo {a:unknowntype} { + puts stderr a=$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 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 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 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 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 method type=list {name value arg} { + #puts $value/$arg + return $value + } + + # handling spaces in "arg" is not not particular nice + D 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 -parameter d + + Class create M + D create d1 -d 1 + C create c1 -mixin M + Object create o + + D method foo-base {x:baseclass} {return $x} + D method foo-class {x:class} {return $x} + D method foo-object {x:object} {return $x} + D method foo-meta {x:metaclass} {return $x} + D method foo-hasmixin {x:hasmixin,arg=::M} {return $x} + D method foo-type {x:object,type=::C} {return $x} + + ? {D info method parameter foo-base} "x:baseclass" + ? {D info method parameter foo-hasmixin} "x:hasmixin,arg=::M" + ? {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-hasmixin c1} "c1" + ? {d1 foo-hasmixin o} \ + {expected object with mixin ::M but got "o" for parameter x} \ + "does not have mixin M" + + ? {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 -parameter {{x 1} {y b} {z {1 2 3}}} + S create s1 { + :method foo {{y:substdefault ${:x}}} { + return $y + } + :method bar {{y:integer,substdefault ${:x}}} { + return $y + } + :method baz {{x:integer,substdefault ${:y}}} { + return $x + } + :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 method foo {{a:substdefault $::aaa}} {return $a}} ::s1::foo + ? {s1 foo} 100 + unset ::aaa + ? {s1 foo} {can't read "::aaa": no such variable} + + ? {s1 method foo {{a:substdefault $aaa}} {return $a}} ::s1::foo + ? {s1 foo} {can't read "aaa": no such variable} + + ? {s1 method foo {{a:substdefault [self]}} {return $a}} ::s1::foo + ? {s1 foo} ::s1 +} + +####################################################### +# testing substdefault for object parameters +####################################################### +Test case substdefault-objparam { + + Class create Bar { + + # simple, implicit substdefault + :attribute {s0 "[self]"} + + # explicit substdefault + :attribute {s1:substdefault "[self]"} + + # unneeded double substdefault + :attribute {s2:substdefault,substdefault "[self]"} + + # substdefault with incremental + :attribute {s3:substdefault "[self]"} { + # 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 -parameter 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 -parameter { + o:object + c:class + c1:class,type=::MC + d:object,type=::C + d1:object,type=C + m:metaclass + mix:hasmixin,arg=M + 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 + } + + ? {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 method type=sex {name value args} { + #puts stderr "[self] slot specific converter" + switch -glob $value { + m* {return m} + f* {return f} + default {error "expected sex but got $value"} + } + } + Class create C { + :method foo {s:sex,multivalued} {return $s} + } + C create c1 + ? {c1 foo {male female mann frau}} "m f m f" + + + 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. + } + + ? {::nx::core::parametercheck mType,slot=::tmpObj,multivalued {1 0}} \ + {invalid value in "1 0": expected false but got 1} \ + "fail on first value" + ? {::nx::core::parametercheck mType,slot=::tmpObj,multivalued {0 0 0}} 1 "all pass" + ? {::nx::core::parametercheck 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 { + :method type=integer {name value arg:optional} { + return [expr {$value + 1}] + } + } + Object create o { + :method foo {x:integer,slot=::mySlot} { + return $x + } + } + + ? {::nx::core::parametercheck integer,slot=::mySlot 1} 1 + ? {o foo 3} 4 +} + +####################################################### +# slot specific converter +####################################################### +Test case slot-specfic-converter { + Class create Person + Person slots { + Attribute create sex -type "sex" { + :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 method foo {s:sex,slot=::Person::slot::sex} {return $s} + ? {p1 foo male} m + ? {p1 sex male} m +} + +####################################################### +# test for setters with parameters +####################################################### +Test case setters { + Object create o + Class create C + + ? {::nx::core::setter o a} "::o::a" + ? {::nx::core::setter C c} "::nx::core::classes::C::c" + ? {o info method definition a} "::o setter a" + ? {o info method parameter a} "a" + ? {o info method args a} "a" + ? {C info method definition c} "::C setter c" + ? {o a 1} "1" + + ? {::nx::core::setter o a:integer} "::o::a" + ? {::nx::core::setter o ints:integer,multivalued} "::o::ints" + ? {::nx::core::setter o o:object} "::o::o" + + ? {o info method name ints} "::o::ints" + ? {o info method definition ints} "::o setter ints:integer,multivalued" + ? {o info method parameter ints} "ints:integer,multivalued" + ? {o info method args ints} "ints" + + ? {o info method name o} "::o::o" + ? {o info method definition o} "::o 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 + ? {::nx::core::setter o {d default}} {parameter "d" is not allowed to have default "default"} + ? {::nx::core::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 -parameter {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 +} +## TODO regression test for type checking, parameter options (initcmd, +## substdefault, combinations with defaults, ...), etc. + +puts stderr =====END Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `tests/parameters.xotcl'. Fisheye: No comparison available. Pass `N' to diff? Index: tests/protected.tcl =================================================================== diff -u --- tests/protected.tcl (revision 0) +++ tests/protected.tcl (revision 752365e2a4c7ef57fc487bfff9bb387e72ccf533) @@ -0,0 +1,101 @@ +package require next +package require xotcl::test +namespace import ::nx::* + +Test parameter count 1 + +Class create C { + :alias SET ::set + :method foo {} {return [self proc]} + :method bar {} {return [self proc]} + :method bar-foo {} { + c1 foo + } + :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} + +::nx::core::methodproperty C SET protected true +? {catch {c1 SET x 1} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {::nx::core::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} + +::nx::core::methodproperty C foo protected true +? {catch {c1 SET x 1} errorMsg; set errorMsg} {::c1: unable to dispatch method 'SET'} +? {::nx::core::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 +? {::nx::core::methodproperty C SET protected} 1 +::nx::core::methodproperty C SET protected false +? {::nx::core::methodproperty C SET protected} 0 +? {::nx::core::methodproperty C foo protected} 1 +::nx::core::methodproperty C foo protected false +? {::nx::core::methodproperty C foo protected} 0 + +? {c1 SET x 3} 3 +? {::nx::core::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 [self proc]} +? {::nx::core::methodproperty C SET protected} 0 +? {c1 SET x 3} 3 +? {::nx::core::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'} + +? {::nx::core::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!} +? {::nx::core::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 {::nx::core::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} +::nx::core::methodproperty o foo redefine-protected true +? {catch {o method foo {} {return 14}} errorMsg; set errorMsg} \ + {Method 'foo' of ::o can not be overwritten. Derive e.g. a sub-class!} + Fisheye: Tag 752365e2a4c7ef57fc487bfff9bb387e72ccf533 refers to a dead (removed) revision in file `tests/protected.xotcl'. Fisheye: No comparison available. Pass `N' to diff?