You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@tcl.apache.org by mx...@apache.org on 2021/03/09 11:29:22 UTC
[tcl-rivet] branch quattuor updated (395b412 -> 45d4469)
This is an automated email from the ASF dual-hosted git repository.
mxmanghi pushed a change to branch quattuor
in repository https://gitbox.apache.org/repos/asf/tcl-rivet.git.
from 395b412 merging master into quattuor, reorganizing internal database and adding new debugging function
new 0d5b566 patching various packages applying changes made in master
new 45d4469 add new form 2.2 package
The 2 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails. The revisions
listed as "add" were already present in the repository and have only
been added to this reference.
Summary of changes:
rivet/packages/dio/dio.tcl | 8 +++-
rivet/packages/dio/dio_Mysql.tcl | 35 ++++++++++++++++-
rivet/packages/form/{form2.tcl => form22.tcl} | 22 ++++++++---
rivet/packages/formbroker/formbroker.tcl | 55 +++++++++++++++------------
4 files changed, 87 insertions(+), 33 deletions(-)
copy rivet/packages/form/{form2.tcl => form22.tcl} (97%)
---------------------------------------------------------------------
To unsubscribe, e-mail: commits-unsubscribe@tcl.apache.org
For additional commands, e-mail: commits-help@tcl.apache.org
[tcl-rivet] 02/02: add new form 2.2 package
Posted by mx...@apache.org.
This is an automated email from the ASF dual-hosted git repository.
mxmanghi pushed a commit to branch quattuor
in repository https://gitbox.apache.org/repos/asf/tcl-rivet.git
commit 45d44698b989ea39c700febd286ac68a970ef91b
Author: Massimo Manghi <mx...@apache.org>
AuthorDate: Tue Mar 9 12:29:03 2021 +0100
add new form 2.2 package
---
rivet/packages/form/form22.tcl | 621 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 621 insertions(+)
diff --git a/rivet/packages/form/form22.tcl b/rivet/packages/form/form22.tcl
new file mode 100644
index 0000000..eb472c8
--- /dev/null
+++ b/rivet/packages/form/form22.tcl
@@ -0,0 +1,621 @@
+# 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 2.2
+
+# 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) [::rivet::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
+
+ # we now guarantee an array, though empty, will exist
+
+ array set 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]
+
+ if {$var == "prefix"} {
+ set prefix $val
+ continue
+ }
+
+ 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)
+ }
+ }
+ 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 {[::rivet::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 {![::rivet::lempty $args]} {
+ # replicated in constructor
+ import_data form $this arguments $args
+ }
+ $this emit_html "<form [argstring arguments]>"
+ }
+
+ #
+ # end - generate the </form>
+ #
+ method end {} {
+ $this emit_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)] } {
+ set data(id) "${prefix}_[incr auto_cnt]"
+ append label { for="} $data(id) {"}
+ } else {
+ append label { for="} $data(id) {"}
+ }
+ append label ">" $data(label) "</label>"
+ }
+
+ # 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)
+ # Alternatively, select a checkbox, if it has no value but a
+ # default value with arbitrary value.
+ if { [info exists data(value)]
+ && [default_value_exists $name $data(value)]
+ || ![info exists data(value)]
+ && $type eq "checkbox"
+ && [info exists DefaultValues($name)]
+ } {
+ 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
+ $this emit_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 file $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 {[::rivet::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 {[::rivet::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 {[::rivet::lempty $labels]} {
+ set labels $values
+ }
+
+ # emit the selector with each label-value pair
+ # we adopt the style imposed by the ::rivet::xml command generating
+ # the innermost elements and then wrapping them up with the 'select' tag
+ set options_list {}
+ foreach label $labels value $values {
+ if {[info exists default_list] && $value in $default_list } {
+ lappend options_list [::rivet::xml $label [list option value $value selected selected]]
+ } else {
+ lappend options_list [::rivet::xml $label [list option value $value]]
+ }
+ }
+ puts [::rivet::xml [join $options_list "\n"] [list select name $name {*}[array get data]]]
+ }
+
+ #
+ # 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)
+ } elseif {[default_exists $name]} {
+ set value [default_value_get $name]
+ }
+ $this emit_html "<textarea name=\"$name\" [argstring data]>$value</textarea>"
+ }
+
+ private method emit_html {html_fragment} {
+
+ if {$emit} {
+ puts $html_fragment
+ } else {
+ return $html_fragment
+ }
+
+ }
+
+ #
+ # 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
+ private variable auto_cnt 0
+ public variable prefix autogen
+ public variable emit true { set noemit [expr !$emit] }
+ public variable noemit false { set emit [expr !$noemit] }
+
+} ; ## ::itcl::class form
---------------------------------------------------------------------
To unsubscribe, e-mail: commits-unsubscribe@tcl.apache.org
For additional commands, e-mail: commits-help@tcl.apache.org
[tcl-rivet] 01/02: patching various packages applying changes made
in master
Posted by mx...@apache.org.
This is an automated email from the ASF dual-hosted git repository.
mxmanghi pushed a commit to branch quattuor
in repository https://gitbox.apache.org/repos/asf/tcl-rivet.git
commit 0d5b56687d9ff258fe976ca4c8759453e8e84898
Author: Massimo Manghi <mx...@apache.org>
AuthorDate: Tue Mar 9 12:28:27 2021 +0100
patching various packages applying changes made in master
---
rivet/packages/dio/dio.tcl | 8 ++++-
rivet/packages/dio/dio_Mysql.tcl | 35 ++++++++++++++++++--
rivet/packages/formbroker/formbroker.tcl | 55 +++++++++++++++++---------------
3 files changed, 70 insertions(+), 28 deletions(-)
diff --git a/rivet/packages/dio/dio.tcl b/rivet/packages/dio/dio.tcl
index 2906a96..4aaa476 100644
--- a/rivet/packages/dio/dio.tcl
+++ b/rivet/packages/dio/dio.tcl
@@ -617,7 +617,7 @@ proc handle {interface args} {
method exec {args} {}
method nextkey {args} {}
method lastkey {args} {}
- method now {} {}
+ method now {} {}
##
## Functions to get and set public variables.
@@ -648,6 +648,12 @@ proc handle {interface args} {
public variable host ""
public variable port ""
+ protected method handle_client_arguments {cargs} { }
+
+ public variable clientargs "" {
+ handle_client_arguments $clientargs
+ }
+
public variable keyfield "" {
if {[llength $keyfield] > 1 && $autokey} {
return -code error "Cannot have autokey and multiple keyfields"
diff --git a/rivet/packages/dio/dio_Mysql.tcl b/rivet/packages/dio/dio_Mysql.tcl
index d9a85ad..aa1ca05 100644
--- a/rivet/packages/dio/dio_Mysql.tcl
+++ b/rivet/packages/dio/dio_Mysql.tcl
@@ -19,7 +19,7 @@
# $Id$
-package provide dio_Mysql 0.3
+package provide dio_Mysql 0.4
namespace eval DIO {
::itcl::class Mysql {
@@ -28,7 +28,7 @@ namespace eval DIO {
constructor {args} {eval configure $args} {
if { [catch {package require Mysqltcl}] \
&& [catch {package require mysqltcl}] \
- && [catch {package require mysql} ] } {
+ && [catch {package require mysql}] } {
return -code error "No MySQL Tcl package available"
}
@@ -53,6 +53,14 @@ namespace eval DIO {
if {![::rivet::lempty $pass]} { lappend command -password $pass }
if {![::rivet::lempty $port]} { lappend command -port $port }
if {![::rivet::lempty $host]} { lappend command -host $host }
+ #if {![::rivet::lempty $encoding]} { lappend command -encoding $encoding }
+
+ if {$clientargs != ""} {
+ set command [lappend command {*}$clientargs]
+ }
+
+ #puts stderr "evaluating $command"
+
if {[catch $command error]} { return -code error $error }
set conn $error
@@ -198,6 +206,29 @@ namespace eval DIO {
}
}
+ protected method handle_client_arguments {cargs} {
+
+ # we assign only the accepted options
+
+ set clientargs {}
+
+ foreach {a v} $cargs {
+
+ if {($a == "-encoding") || \
+ ($a == "-localfiles") || \
+ ($a == "-ssl") || \
+ ($a == "-sslkey") || \
+ ($a == "-sslcert") || \
+ ($a == "-sslca") || \
+ ($a == "-sslcapath") || \
+ ($a == "-sslcipher") || \
+ ($a == "-socket")} {
+ lappend clientargs $a $v
+ }
+
+ }
+ }
+
public variable interface "Mysql"
private variable conn
diff --git a/rivet/packages/formbroker/formbroker.tcl b/rivet/packages/formbroker/formbroker.tcl
index 3edca9b..f81363f 100644
--- a/rivet/packages/formbroker/formbroker.tcl
+++ b/rivet/packages/formbroker/formbroker.tcl
@@ -1,7 +1,7 @@
# -- formbroker.tcl
#
-# Form validation and sanitation tool. Kindly donated by
-# Karl Lehenbauer (Flightaware.com)
+# Form validation and sanitation tool. Developed starting from
+# code initially donated by Karl Lehenbauer (Flightaware.com)
#
# Copyright 2017 The Rivet Team
#
@@ -25,7 +25,7 @@
namespace eval FormBroker {
variable form_definitions [dict create]
variable form_list [dict create]
- variable string_quote force_quote
+ variable string_quoting force_quote
variable form_count 0
#
# response_security_error - issue an error with errorCode
@@ -104,7 +104,7 @@ namespace eval FormBroker {
force_sanitize_response_strings response {*}$args
foreach var $args {
- set response($var) [$string_quote $response($var)]
+ set response($var) [$string_quoting $response($var)]
}
}
@@ -122,7 +122,7 @@ namespace eval FormBroker {
require_response_vars response {*}$args
foreach var $args {
- set response($var) [$string_quote $response($var)]
+ set response($var) [$string_quoting $response($var)]
}
}
@@ -303,19 +303,19 @@ namespace eval FormBroker {
set value [dict get $variable_d var]
if {[dict get $variable_d force_quote] || $force_quote_var} {
- set value [$string_quote $value]
+ set value [$string_quoting $value]
}
return $valid
}
- # -- constrain_bounds
+ # -- bounds_consistency
#
# During the form creation stage this method is called
# to correct possible inconsistencies with a field bounds
# definition
#
- proc constrain_bounds {field_type _bounds} {
+ proc bounds_consistency {field_type _bounds} {
upvar $_bounds bounds
switch $field_type {
@@ -457,10 +457,10 @@ namespace eval FormBroker {
proc validate { form_name args } {
variable form_definitions
variable form_list
- variable string_quote
+ variable string_quoting
set force_quote_vars 0
- set arguments $args
+ set arguments $args
if {[llength $arguments] == 0} {
error "missing required arguments"
} elseif {[llength $arguments] > 3} {
@@ -531,7 +531,7 @@ namespace eval FormBroker {
if {[dict get $variable_d force_quote] || $force_quote_vars} {
- set response_a($var) [$string_quote [dict get $variable_d var]]
+ set response_a($var) [$string_quoting [dict get $variable_d var]]
}
}
@@ -570,7 +570,7 @@ namespace eval FormBroker {
set response($var_name) $var
} elseif {[info exists default]} {
set response($var_name) $default
- }
+ }
}
@@ -594,7 +594,7 @@ namespace eval FormBroker {
# -- destroy
#
# this method is designed to be called
- # by an 'trace unset' event on the variable
+ # by a 'trace unset' event on the variable
# keeping the form description object.
#
@@ -629,7 +629,7 @@ namespace eval FormBroker {
variable form_definitions
variable form_list
variable form_count
- variable string_quote
+ variable string_quoting
set form_name "form${form_count}"
incr form_count
@@ -637,10 +637,10 @@ namespace eval FormBroker {
catch { namespace delete $form_name }
namespace eval $form_name {
- foreach cmd { validate failing \
- form_definition \
- result validate_var \
- destroy validation_error \
+ foreach cmd { validate failing \
+ form_definition \
+ result validate_var \
+ destroy validation_error \
response reset } {
lappend cmdmap $cmd [list [namespace parent] $cmd [namespace tail [namespace current]]]
}
@@ -656,7 +656,7 @@ namespace eval FormBroker {
form_validation FB_OK \
failing {} \
default "" \
- quoting $string_quote]
+ quoting $string_quoting]
while {[llength $args]} {
@@ -671,7 +671,7 @@ namespace eval FormBroker {
error [list RIVET INVALID_QUOTING_PROC \
"Non existing quoting proc '$quoting'"]
}
- set string_quote $quoting
+ set string_quoting $quoting
}
continue
@@ -734,16 +734,15 @@ namespace eval FormBroker {
while {[llength $e] > 0} {
set e [::lassign $e field_spec]
-
switch $field_spec {
check_routine -
validator {
set e [::lassign $e validator]
}
- length -
+ maxlength -
bounds {
set e [::lassign $e bounds]
- constrain_bounds $field_type bounds
+ bounds_consistency $field_type bounds
}
default {
set e [::lassign $e default]
@@ -788,10 +787,16 @@ namespace eval FormBroker {
return [namespace current]::$form_name
}
- proc form_exists {form_cmd} {
+ # -- form_exists
+ #
+ # check the existence of the form named 'form_name' in the form broker
+ # database. The check is done by simply checking one of dictionaries that
+ # keep the internal database of form definitions
+
+ proc form_exists {form_command_name} {
variable form_definitions
- return [dict exists $form_definitions [namespace tail $form_cmd]]
+ return [dict exists $form_definitions [namespace tail $form_command_name]]
}
proc creategc {varname args} {
---------------------------------------------------------------------
To unsubscribe, e-mail: commits-unsubscribe@tcl.apache.org
For additional commands, e-mail: commits-help@tcl.apache.org