Dear Rivet guys, I agreed with Massimo that we try to fix the issues in the form package. I will make a proposition and Massimo (or someone else) is doing the fine tuning.
Attached is my proposition for review.
Comments:
load_response:
- insured that output array exists
- speed optimisation: reordered ifs to make less comparisons
form.tcl:
- return -> return ""
May have side effects otherwise, as last result is returned
- eval cmd $name $list -> ... cmd $name {*}$list
-> otherwise issues may raise if name has space.
- DefaultValues and list processing
There were many issues when default values were treated as lists.
Now, they are treated as lists if "__$name" exists (as outputted by
load_response).
The following widgets require lists:
radiobuttons checkboxes select -multiple
and all others require values.
The first element is used if a value is required and a list is given.
- Capsulated Default value processing internally be the protected
methods default_*
- enhanced public method default_value by option "-list" to get/set a
list of default values.
This is specially important to set the current value of the list
widgets (because there is no such option prevued):
my_form default_value -list -- "option check default" {"o 2" "o 3"}
my_form checkboxes "option check default"\
-values {"o 1" "o 2" "o 3" "o 4"}\
-labels {"l 1" "l 2" "l 3" "l 4"}
- Use uuid package only if it is loaded.
I personally didn't like that. In addition, there was no
"package require uuid".
IMHO the code should export the uuid values, if they are generated
on the fly. It is "half baken".
- Added widget type "checkboxes".
The manual describes "-values" and "-labels" for "checkbox", which
do not exist. So, I created method "checkboxes" with those values.
testform.tcl
My form test file.
Footnote:
for me, form "my form" raises an Itcl error.
I have forwarded this to Arnulf Wiedemann.
Enjoy,
Harald
# form.tcl -- generate forms automatically. # Copyright 2002-2004 The Apache Software Foundation # Licensed under the Apache License, Version 2.0 (the "License"); # you may not use this file except in compliance with the License. # You may obtain a copy of the License at # http://www.apache.org/licenses/LICENSE-2.0 # Unless required by applicable law or agreed to in writing, software # distributed under the License is distributed on an "AS IS" BASIS, # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. # See the License for the specific language governing permissions and # limitations under the License. package require Itcl package provide form 1.0 # # Rivet form class # ::itcl::class form { constructor {args} { # set the form method to be a post and the action to be # a refetching of the current page set arguments(method) post set arguments(action) [env DOCUMENT_URI] # use $this for the type for form-global stuff like form arguments import_data form $this arguments $args if {[info exists arguments(defaults)]} { # make the public variable contain the name of the array # we are sucking default values out of set defaults $arguments(defaults) upvar 1 $arguments(defaults) callerDefaults array set DefaultValues [array get callerDefaults] unset arguments(defaults) } else { array set DefaultValues {} } } destructor { } method destroy {} { ::itcl::delete object $this } # # import_data -- given a field type, field name, name of an array, and a # list of key-value pairs, prepend any default key-value pairs, # then store the resulting key-value pairs in the named array # protected method import_data {type name arrayName list} { upvar 1 $arrayName data # # If there are elements in the defaultArgs array for the # specified type, combine them with the list of key-value # pairs, putting the DefaultArgs values first so the # key-value pairs from list can possibly override them. # if {[info exists DefaultArgs($type)]} { set list [concat $DefaultArgs($type) $list] } # # if we don't have an even number of key-value pairs, # that just ain't right # if {[llength $list] % 2} { return -code error "Unmatched key-value pairs" } # # for each key-value pair in the list, strip the first # dash character from the key part and map it to lower # case, then use that as the key for the passed-in # array and store the corresonding value in there # # we also prep and return the list of key-value pairs, normalized # with the lowercase thing # set return "" foreach {var val} $list { set var [string range [string tolower $var] 1 end] set data($var) $val if {($var == "values") || ($var == "labels")} { continue } lappend return -$var $val } return $return } # # argstring - given an array name, construct a string of the # style key1="data1" key2="data2" etc for each key value pair in the # array # protected method argstring {arrayName} { upvar 1 $arrayName data set string "" foreach arg [lsort [array names data]] { append string " $arg=\"$data($arg)\"" } return $string } # # default_value ?-list? ?--? name ?value? # # If value is not given, returns a default value # for that name if one exists, else an empty list. # # if a name and a value are given, the default value is set to that # name (and the new default value is returned). # # The default value is a list if "-list" is given. method default_value {args} { # Command line if {[lindex $args 0] eq "-list"} { set isList 1 set args [lrange $args 1 end] } if {[lindex $args 0] eq "--"} { set args [lrange $args 1 end] } switch -exact -- [llength $args] { 1 { # Return default value lassign $args name if {default_exists $name]} { if {[info exists isList]} { return [default_list_get $name] } else { return [default_value_get $name] } } else { return "" } } 2 { # Set default value lassign $args name value set DefaultValues($name) $value if {[info exists isList]} { set DefaultValues(__$name) 1 } else { unset -nocomplain DefaultValues(__$name) 0 } } default { error "wrong argument count" } } } # # default_exists - return true, if a default value exists protected method default_exists {name} { return [info exists DefaultValues($name)] } # # default_list_get - get the default value as a list # return with error if there is no default value protected method default_list_get {name} { if {[info exists DefaultValues(__$name)]} { return $DefaultValues($name) } else { return [list $DefaultValues($name)] } } # # default_value_get - get the default value as a value # return with error if there is no default value protected method default_value_get {name} { if {[info exists DefaultValues(__$name)]} { return [lindex $DefaultValues($name) 0] } else { return $DefaultValues($name) } } # # default_value_exists - return true, if the given value exists in the # default list protected method default_value_exists {name value} { if { ! [info exists DefaultValues($name)] } { return 0 } if {[info exists DefaultValues(__$name)]} { return [expr {$value in $DefaultValues($name)}] } return [expr {$value eq $DefaultValues($name)}] } # # default_args - given a type and a variable number of arguments, # if there are no arguments other than the type, return the # element of that name from the DefaultArgs array, if that element # exists, else return an empty list. # # if a name and a value are given, sets the DefaultArgs to the variable # list of arguments. # method default_args {type args} { # if only one argument was specified if {[lempty $args]} { if {![info exists DefaultArgs($type)]} { return ""} return $DefaultArgs($type) } # make sure we have an even number of key-value pairs if {[llength $args] % 2} { return -code error "Unmatched key-value pairs" } # set the DefaultArgs for the specified type return [set DefaultArgs($type) $args] } # # start - generate the <form> with all of its arguments # method start {{args ""}} { if {![lempty $args]} { # replicated in constructor import_data form $this arguments $args } html "<form [argstring arguments]>" } # # end - generate the </form> # method end {} { html "</form>" } # # field - emit a field of the given field type and name, including # any default key-value pairs defined for this field type and # optional key-value pairs included with the statement # method field {type name args} { # import any default key-value pairs, then any specified in this # field declaration import_data $type $name data $args switch -- $type { "radio" - "checkbox" { # if there's a label then prepare to output it. if {[info exists data(label)]} { set label "<label" # if there's no id defined, generate something unique so we can reference it. if { ![info exists data(id)] } { if { [namespace exists ::uuid] } { set data(id) "autogen_[::uuid::uuid generate]" append label { for="} $data(id) {"} } } else { append label { for="} $data(id) {"} } append label ">" $data(label) "</label>" } # ...and if there is a default value for this field # and it matches the value we have for it, make # the field show up as selected (checked) if { [info exists data(value)] && [default_value_exists $name $data(value)] } { set data(checked) "checked" } } } # For non multi-choice widgets: set default value if there is no value # given if { ! [info exists data(value)] && [default_exists $name] && $type ni {"select" "radio" "checkbox"} } { set data(value) [default_value_get $name] } # generate the field definition set string "<input type=\"$type\" name=\"$name\" [argstring data] />" if {[info exists label]} { append string $label } # ...and emit it html $string } # # text -- emit an HTML "text" field # method text {name args} { field text $name {*}$args } # # password -- emit an HTML "password" field # method password {name args} { field password $name {*}$args } # # hidden -- emit an HTML "hidden" field # method hidden {name args} { field hidden $name {*}$args } # # submit -- emit an HTML "submit" field # method submit {name args} { field submit $name {*}$args } # # button -- emit an HTML "button" field # method button {name args} { field button $name {*}$args } # # reset -- emit an HTML "reset" button # method reset {name args} { field reset $name {*}$args } # # image -- emit an HTML image field # method image {name args} { field image $name {*}$args } # # checkbox -- emit an HTML "checkbox" form field # method checkbox {name args} { field checkbox $name {*}$args } # # radio -- emit an HTML "radiobutton" form field # method radio {name args} { field radio $name {*}$args } # # color -- emit an HTML 5 "color" form field # method color {name args} { field color $name {*}$args } # # date -- emit an HTML 5 "date" form field # method date {name args} { field date $name {*}$args } # # datetime -- emit an HTML 5 "datetime" form field # method datetime {name args} { field datetime $name {*}$args } # # datetime_local -- emit an HTML 5 "datetime-local" form field # method datetime_local {name args} { field datetime-local $name {*}$args } # # email -- emit an HTML 5 "email" form field # method email {name args} { field email $name {*}$args } # # file -- emit an HTML 5 "file" form field # method file {name args} { field email $name {*}$args } # # month -- emit an HTML 5 "month" form field # method month {name args} { field month $name {*}$args } # # number -- emit an HTML 5 "number" form field # method number {name args} { field number $name {*}$args } # # range -- emit an HTML 5 "range" form field # method range {name args} { field range $name {*}$args } # # search -- emit an HTML 5 "search" form field # method search {name args} { field search $name {*}$args } # # tel -- emit an HTML 5 "tel" form field # method tel {name args} { field tel $name {*}$args } # # time -- emit an HTML 5 "time" form field # method time {name args} { field time $name {*}$args } # # url -- emit an HTML 5 "url" form field # method url {name args} { field url $name {*}$args } # # week -- emit an HTML 5 "week" form field # method week {name args} { field week $name {*}$args } # # radiobuttons -- # method radiobuttons {name args} { set data(values) [list] set data(labels) [list] set list [import_data radiobuttons $name data $args] if {[lempty $data(labels)]} { set data(labels) $data(values) } foreach label $data(labels) value $data(values) { radio $name {*}$list -label $label -value $value } } # # checkboxes -- # method checkboxes {name args} { set data(values) [list] set data(labels) [list] set list [import_data checkboxes $name data $args] if {[lempty $data(labels)]} { set data(labels) $data(values) } foreach label $data(labels) value $data(values) { checkbox $name {*}$list -label $label -value $value } } # # select -- generate a selector # # part of the key value pairs can include -values with a list, # and -labels with a list and it'll populate the <option> # elements with them. if one matches the default value, # it'll select it too. # method select {name args} { # start with empty values and labels so they'll exist even if not set set data(values) [list] set data(labels) [list] # import any default data and key-value pairs from the method args import_data select $name data $args # pull the values and labels into scalar variables and remove them # from the data array set values $data(values) set labels $data(labels) unset data(values) data(labels) # get the list of default values if {[default_exists $name]} { set default_list [default_list_get $name] } # if there is a value set in the value field of the data array, # use that instead (that way if we're putting up a form with # data already, the data'll show up) # This data is a list for multiple forms if {[info exists data(value)]} { if {[info exists data(multiple)]} { set default_list $data(value) } else { set default_list [list $data(value)] } unset data(value) } # # if there are no separate labels defined, use the list of # values for the labels # if {[lempty $labels]} { set labels $values } # emit the selector html "<select name=\"$name\" [argstring data]>" # emit each label-value pair foreach label $labels value $values { if {[info exists default_list] && $value in $default_list } { set string "<option value=\"$value\" selected=\"selected\">" } else { set string "<option value=\"$value\">" } html "$string$label</option>" } html "</select>" } # # textarea -- emit an HTML "textarea" form field # method textarea {name args} { import_data textarea $name data $args set value "" if {[info exists data(value)]} { set value $data(value) unset data(value) } html "<textarea name=\"$name\" [argstring data]>$value</textarea>" } # # defaults -- when set, the value is the name of an array to suck # the key-value pairs out of and copy them into DefaultValues # public variable defaults "" { upvar 1 $defaults array array set DefaultValues [array get array] } private variable DefaultValues private variable DefaultArgs private variable arguments } ; ## ::itcl::class form
###
##
## load_response ?arrayName?
## Load any form variables passed to this page into an array.
##
## arrayName - Name of the array to set. Default is 'response'.
##
## $Id: load_response.tcl 584555 2007-10-14 15:22:23Z mxmanghi $
##
###
proc load_response {{arrayName response}} {
upvar 1 $arrayName response
# be shure array exists
array set response {}
foreach {var elem} [var all] {
if {[info exists response(__$var)]} {
# we have seen var multiple times already, add to the list
lappend response($var) $elem
} elseif {[info exists response($var)]} {
# second occurence of var, convert response(var) list:
set response($var) [list $response($var) $elem]
set response(__$var) ""
} else {
# first time seeing this var
set response($var) $elem
}
}
}
<<< text/html; name="formtest.rvt": Unrecognized >>>
--------------------------------------------------------------------- To unsubscribe, e-mail: rivet-dev-unsubscr...@tcl.apache.org For additional commands, e-mail: rivet-dev-h...@tcl.apache.org
