package provide Form 1.0
namespace eval Form {
variable inherit {
-type -maxlength -size -inline
-disabled -readonly -template -class
-onfocus -onblur -onselect -onchange
}
variable field_fields {
-type -maxlength -name -size -value
-legend -label -prolog -epilog -inline -acronym -alt
-checked -disabled -readonly -tabindex
-src -onfocus -onblur -onselect -onchange
-class -rows -cols
}
variable defaults {
-method post
-type text
-maxlength 64
-size 30
-inline 1
}
proc parse_field {name f fieldset} {
set field [dict create -label $name -name $name]
# grab defaults from fieldset
variable inherit
dict for {k v} $fieldset {
if {$k in $inherit} {
dict set field $k $v
}
}
variable field_fields
foreach {key val} $f {
if {$key in $field_fields} {
dict set field $key $val
} else {
error "Unknown argument $key in field $name"
}
}
return $field
}
proc parse_fieldset {name fs form} {
set fieldset [dict create -label $name -inline 0]
# grab defaults from form
variable inherit
dict for {k v} $form {
if {$k in $inherit} {
dict set fieldset $k $v
}
}
set fields {}
foreach {key val} $fs {
if {[string match -* $key]} {
dict set fieldset $key $val
} else {
lappend fields $key
dict set fieldset $key [parse_field $key $val $fieldset]
}
}
dict set fieldset -fields $fields
return $fieldset
}
proc parse {text args} {
variable defaults
set form [dict merge $defaults $args]
set fieldsets {}
foreach {key val} $text {
if {[string match -* $key]} {
dict set form $key $val
} else {
lappend fieldsets $key
dict set form $key [parse_fieldset $key $val $form]
}
}
dict set form -fieldsets $fieldsets
return $form
}
proc label {text} {
set result {}
foreach word [split $text] {
if {$word eq ""} continue
if {[string length $word] > 3} {
lappend result [string totitle $word]
} else {
lappend result $word
}
}
return [join $result]
}
proc html {form args} {
set form [parse $form {*}$args]
if {[dict exists $form -record]} {
set record [dict get $form -record]
#puts stderr "form html record: $record"
Debug {form html record: $record}
} else {
set record [dict create]
}
set html ""
if {[dict exists $form -class]} {
set class [dict get $form -class]
} else {
set class Form
}
if {[dict exists $form -action]} {
append html "<form class='$class' action='[dict get $form -action]' method='[dict get $form -method]'>\n"
}
if {[dict exists $form -prolog]} {
append html [dict get $form -prolog] \n
}
foreach fsn [dict get $form -fieldsets] {
set fs [dict get $form $fsn]
append html <fieldset> \n
append html <legend> [label [dict get $fs -label]] </legend> \n
if {[dict exists $fs -prolog]} {
append html [dict get $form -prolog] \n
}
foreach fn [dict get $fs -fields] {
set f [dict get $form $fsn $fn]
if {[dict get $f -type] ne "hidden"} {
if {![dict get $f -inline]} {
append html <p>
}
append html <label>
if {[dict exists $f -acronym]} {
append html "<acronym title='[dict get $f -acronym]'>"
append html [label [dict get $f -label]]
append html </acronym>
append html ": "
} else {
append html [label [dict get $f -label]] ": "
}
append html </label>
}
if {[dict exists $f -type] && ([dict get $f -type] eq "textarea")} {
append html <textarea
set attrs {type name readonly rows cols}
} else {
append html <input
set attrs {type maxlength name size alt readonly}
}
foreach x $attrs {
if {[dict exists $f -$x]} {
append html " $x='[dict get $f -$x]'"
}
}
if {[dict exists $f -name]} {
set name [dict get $f -name]
} else {
set name $fn
}
if {[dict exists $f -type] && ([dict get $f -type] ne "textarea")} {
if {[dict exists $f -value]} {
append html " value='[dict get $f -value]'"
} elseif {[dict exists $record $name]} {
#puts stderr "REC: $name / [dict get $record $name] / [armour [dict get $record $name]] / $record"
append html " value='[armour [dict get $record $name]]'"
} elseif {[dict exists $form -template]
&& ([dict get $form -template] ne "")} {
set t [dict get $form -template]
append html " value='[string map [list % $name] $t]'"
}
append html /> \n
} else {
append html > \n
if {[dict exists $f -value]} {
append html [dict get $f -value]
} elseif {[dict exists $form -template]
&& ([dict get $form -template] ne "")} {
set t [dict get $form -template]
append html [string map [list % [dict get $f -name]] $t]
}
append html </textarea> \n
}
if {[dict exists $f -legend]} {
append html [dict get $f -legend]
}
if {![dict get $f -inline]} {
append html </p>
}
if {[dict exists $f -text]} {
append html <p> [dict get $f -text] </p> \n
}
}
if {[dict exists $fs -epilog]} {
append html <p> [dict get $fs -epilog] </p> \n
}
append html </fieldset> \n
}
if {[dict exists $form -epilog]} {
append html [dict get $form -epilog] \n
}
if {[dict exists $form -submit]} {
append html "<input type='submit' value='[dict get $form -submit]'/>" \n
}
if {[dict exists $form -action]} {
append html </form>
}
return $html
}
proc load {path args} {
set fd [open $path]
set content [read $fd]
close $fd
if {$args ne {}} {
set content [string map $args $content]
}
#puts stderr "Load: $content"
return [html $content]
}
namespace export -clear *
namespace ensemble create -subcommands {}
}
if {[info exists argv0] && ($argv0 eq [info script])} {
puts "<html><head></head><body>"
puts [Form html {
-submit "Create New Account"
-prolog "<p>This is a form to enter your account details</p>"
-epilog "<p>When you create the account instructions will be emailed to you. Make sure your email address is correct.</p>"
details {
-label "Account Details"
-inline 1
user {
-acronym "Your preferred username (only letters, numbers and spaces)"
}
email {
-acronym "Your email address"
-value moop
}
hidden {
-type hidden
}
}
passwords {
-text "Type in your preferred password, twice. Leaving it blank will generate a random password for you."
-type password
-inline 1
password {}
repeat {}
}
personal {
-label "Personal Information"
name {
-name fullname
-acronym "Full name to be used in email."
}
phone {
-acronym "Phone number for official contact"
}
}
} -action http:moop.html]
puts "</body>\n</html>"
}HJG On my Tcl 8.4 installation, I get an error 'invalid command name "dict" ... line 165'.RLH dict is in 8.5...but I think that there was a backport to 8.4, if you want to try it.MHo Changed {expand} to {*}
