Index: library/nx/nx.tcl =================================================================== diff -u -rb6fa800493538a2f179224f7f1717eb70913dd8b -rbabe6447be02524ff70f5af3ee83ae5aa678b6d1 --- library/nx/nx.tcl (.../nx.tcl) (revision b6fa800493538a2f179224f7f1717eb70913dd8b) +++ library/nx/nx.tcl (.../nx.tcl) (revision babe6447be02524ff70f5af3ee83ae5aa678b6d1) @@ -1022,6 +1022,51 @@ } } + # + # Translate substdefault bitpattern to options passed to the Tcl + # "subst" command + # + MetaSlot public object method substDefaultOptions { + bitPattern + } { + # backslashes, variables, commands + set options {} + if {($bitPattern & 0b100) == 0} { + lappend options -nobackslashes + } + if {($bitPattern & 0b010) == 0} { + lappend options -novariables + } + if {($bitPattern & 0b001) == 0} { + lappend options -nocommands + } + return $options + } + + # + # Given a dict of parameter options, translate this into a spec + # which can be passed to nsf::is for value checking + # + MetaSlot public object method optionsToValueCheckingSpec { + options + } { + set noptions "" + if {[dict exists $options -type]} { + set type [dict get $options -type] + if {[string match "::*" $type]} { + lappend noptions object type=$type + } elseif {$type eq "switch"} { + lappend noptions boolean + } else { + lappend noptions $type + } + } + if {[dict exists $options -multiplicity]} { + lappend noptions [dict get $options -multiplicity] + } + return [join $noptions ,] + } + MetaSlot public object method parseParameterSpec { {-class ""} {-defaultopts ""} @@ -2272,38 +2317,52 @@ # get name and list of parameter options lassign [::nx::MetaSlot parseParameterSpec -class $class -target [self] $spec] \ name parameterOptions class options - array set opts $options - if {[info exists opts(-configurable)]} { - set configurable $opts(-configurable) + #puts "[self] object variable $spec name <$name> parameterOptions <$parameterOptions> class <$class> options <$options>" + + + if {[dict exists $options -configurable]} { + set configurable [dict get $options -configurable] } if {![info exists trace] && [info exists :trace] && ${:trace} ne "none"} { set trace ${:trace} } - #puts "[self] object variable haveDefault? [info exists defaultValue] opts <$parameterOptions> options <$options>" + #puts "[self] object variable $spec haveDefault? [info exists defaultValue] opts <$parameterOptions> options <$options>" - if {[info exists defaultValue] && "substdefault" in [split $parameterOptions ,] + if {[info exists defaultValue] + && [dict exists $options -substdefault] && [string match {*\[*\]*} $defaultValue] } { if {![info complete $defaultValue]} { return -code error "substdefault: default '$defaultValue' is not a complete script" } - # TODO: This should be -novariables, and protected by - # [apply]. For now, untouched, as ArgumentDefaults() has no - # substitution restrictions. - set defaultValue [subst $defaultValue] + set substDefaultOptions [::nx::MetaSlot substDefaultOptions [dict get $options -substdefault]] + set defaultValue [subst {*}$substDefaultOptions $defaultValue] } - - if {$initblock eq "" && !$configurable && !$incremental - && $accessor eq "none" && ![info exists trace]} { + + # + # Check for slot-less variables + # + if {$initblock eq "" + && !$configurable + && !$incremental + && $accessor eq "none" + && ![info exists trace] + } { # - # Slot-less variable + # The variable is slot-less. # #puts "[self]... slotless variable $spec" - set isSwitch [regsub {\mswitch\M} $parameterOptions boolean parameterOptions] + # The following tasks have to be still performed: + # - If there is an explicit default value, the value has to + # be checked. + # - if the type is a switch, we have to set the implicit + # default value, when there is not explicit default + # + set isSwitch [expr {[dict exists $options -type] && [dict get $options -type] eq "switch"}] if {[info exists defaultValue]} { if {[info exists :$name] && !$nocomplain} { @@ -2312,14 +2371,14 @@ } if {$parameterOptions ne ""} { #puts stderr "*** ::nsf::is $parameterOptions $defaultValue // opts=$options" - # we rely here that the nsf::is error message expresses the implementation limits - set noptions {} - foreach o [split $parameterOptions ,] { - if {$o ni {noconfig substdefault}} {lappend noptions $o} - } - - set parameterOptions [join $noptions ,] - ::nsf::is -complain $parameterOptions $defaultValue + # + # Extract from the options a spec for value checking, and + # let "nsf::is" perform the actual checking. In case, the + # check fails, "nsf::is" will raise an error with and error + # message communicating the failure. + # + set nspec [::nx::MetaSlot optionsToValueCheckingSpec $options] + ::nsf::is -complain $nspec $defaultValue } else { set name $spec } Index: tests/parameters.test =================================================================== diff -u -rdc94a1f141b1c6a106d0ee142c9df2743ac82e67 -rbabe6447be02524ff70f5af3ee83ae5aa678b6d1 --- tests/parameters.test (.../parameters.test) (revision dc94a1f141b1c6a106d0ee142c9df2743ac82e67) +++ tests/parameters.test (.../parameters.test) (revision babe6447be02524ff70f5af3ee83ae5aa678b6d1) @@ -2622,10 +2622,11 @@ :object variable foo:switch :object variable bar:switch 1 }} ::o1 - ? {o1 eval {set :foo}} 0 - ? {o1 eval {set :bar}} 1 + ? {o1 eval {set :foo}} 0 "check value of switch variable without default" + ? {o1 eval {set :bar}} 1 "check value of switch variable with default" } + # # Test slots with configparameter true/false, accessor true/false # against "slot definitions" and "info parameter" @@ -3541,7 +3542,30 @@ "expected object of type ::ns1::ns2::C but got \"::c\" for parameter \"p1\"" } +# +# Check per-object variable default value checking. +# Every test can be performed only once due to the intended semantics +# +nx::test configure -count 1 +nx::test case check-object-variables { + ::nx::Object create o1 + ? {::o1 object variable v01:int 1} {} + ? {::o1 object variable v11:int a} {expected integer but got "a"} + ? {::o1 object variable v02:object,type=nx::Object ::nx::Object} {} + ? {::o1 object variable v12:object,type=nx::Object a} {expected object but got "a"} + + ? {::o1 object variable v03:upper A} {} + ? {::o1 object variable v13:upper a} {expected upper but got "a"} + + ? {::o1 object variable v04:lower,1..n "a b c"} {} + ? {::o1 object variable v14:lower,1..n "a B c"} {invalid value in "a B c": expected lower but got "B"} + + ? {::o1 object variable err:object,type:nx::Object ::nx::Object} {invalid value constraints "type:nx::Object"} +} + + + # # Local variables: # mode: tcl Index: tests/substdefault.test =================================================================== diff -u -rb6fa800493538a2f179224f7f1717eb70913dd8b -rbabe6447be02524ff70f5af3ee83ae5aa678b6d1 --- tests/substdefault.test (.../substdefault.test) (revision b6fa800493538a2f179224f7f1717eb70913dd8b) +++ tests/substdefault.test (.../substdefault.test) (revision babe6447be02524ff70f5af3ee83ae5aa678b6d1) @@ -28,7 +28,7 @@ # prefixes) -nx::test case substdefaultoptions { +nx::test case substdefaultoptions-class { set ::X 123 nx::Class create D { @@ -50,17 +50,80 @@ #? {::d1 eval :__object_configureparameter} "" - ? {d1 show :a} {a $::X [set x 4] \t} - ? {d1 show :b} {a 123 4 } - ? {d1 show :c} {a 123 4 } - ? {d1 show :d} {a $::X [set x 4] } - ? {d1 show :e} {a 123 [set x 4] \t} - ? {d1 show :f} {a $::X 4 \t} - ? {d1 show :g} {a $::X [set x 4] \t} + ? {d1 show :a} {a $::X [set x 4] \t} "no substdefault" + ? {d1 show :b} {a 123 4 } "substdefault no options" + ? {d1 show :c} {a 123 4 } "substdefault 0b111 subst all" + ? {d1 show :d} {a $::X [set x 4] } "substdefault 0b100 -novars -nocommands" + ? {d1 show :e} {a 123 [set x 4] \t} "substdefault 0b010 -nocommands -nobackslashes" + ? {d1 show :f} {a $::X 4 \t} "substdefault 0b001 -novars -nobackslashes" + ? {d1 show :g} {a $::X [set x 4] \t} "substdefault 0b000 -nocommands -novars -nobackslashes" unset ::X } +# +# same test cases as above, buf for object cases +# +nx::test case substdefaultoptions-object-slot { + set ::X 123 + nx::Object create d1 { + + :object property {a {a $::X [set x 4] \t}} + :object property {b:substdefault {a $::X [set x 4] \t}} + :object property {c:substdefault=0b111 {a $::X [set x 4] \t}} + :object property {d:substdefault=0b100 {a $::X [set x 4] \t}} + :object property {e:substdefault=0b010 {a $::X [set x 4] \t}} + :object property {f:substdefault=0b001 {a $::X [set x 4] \t}} + :object property {g:substdefault=0b000 {a $::X [set x 4] \t}} + + :public object method show {v} { + return [set $v] + } + } + + ? {d1 show :a} {a $::X [set x 4] \t} "no substdefault" + ? {d1 show :b} {a 123 4 } "substdefault no options" + ? {d1 show :c} {a 123 4 } "substdefault 0b111 subst all" + ? {d1 show :d} {a $::X [set x 4] } "substdefault 0b100 -novars -nocommands" + ? {d1 show :e} {a 123 [set x 4] \t} "substdefault 0b010 -nocommands -nobackslashes" + ? {d1 show :f} {a $::X 4 \t} "substdefault 0b001 -novars -nobackslashes" + ? {d1 show :g} {a $::X [set x 4] \t} "substdefault 0b000 -nocommands -novars -nobackslashes" + + unset ::X +} + +nx::test case substdefaultoptions-object-noslot { + set ::X 123 + nx::Object create d1 { + + :object variable a {a $::X [set x 4] \t} + :object variable b:substdefault {a $::X [set x 4] \t} + :object variable c:substdefault=0b111 {a $::X [set x 4] \t} + :object variable d:substdefault=0b100 {a $::X [set x 4] \t} + :object variable e:substdefault=0b010 {a $::X [set x 4] \t} + :object variable f:substdefault=0b001 {a $::X [set x 4] \t} + :object variable g:substdefault=0b000 {a $::X [set x 4] \t} + + :public object method show {v} { + return [set $v] + } + } + + ? {d1 show :a} {a $::X [set x 4] \t} "no substdefault" + ? {d1 show :b} {a 123 4 } "substdefault no options" + ? {d1 show :c} {a 123 4 } "substdefault 0b111 subst all" + ? {d1 show :d} {a $::X [set x 4] } "substdefault 0b100 -novars -nocommands" + ? {d1 show :e} {a 123 [set x 4] \t} "substdefault 0b010 -nocommands -nobackslashes" + ? {d1 show :f} {a $::X 4 \t} "substdefault 0b001 -novars -nobackslashes" + ? {d1 show :g} {a $::X [set x 4] \t} "substdefault 0b000 -nocommands -novars -nobackslashes" + + ? {d1 object variable x:int,substdefault 1} {} + ? {d1 show :x} 1 + unset ::X +} + + + ####################################################### # subst default tests for method properties #######################################################