FormBooleanElement
FormChoicesElement
FormElement
FormHiddenElement
FormPasswordElement
FormTextAreaElement
FormTextElement
WebForm
cgi_import_form
cgi_pkg_attrs
cgi_subhex
html
html_field_description
neo_cgi_import_form
FormBooleanElement - an [incr tcl] class
FormBooleanElement object
inherits FormElement
object configure
config
object build_form_element
config
object getf
args
object setf
value
object blank
# # boolean element (checkbutton) form element class # inherit FormElement method configure {config} {} method build_form_element {config} { upvar #0 $array myArray html_field_description $text set checked "" if {$myArray($name)} { set checked " checked" } html "<input type=\"checkbox\" name=\"$array:$name\" value=\"$myArray($name)\"$checked>\n" } method getf {args} { global $array return [set ${array}($name)] } method setf {value} { global $array set ${array}($name) $value return } method blank {} { setf "" }
FormChoicesElement - an [incr tcl] class
FormChoicesElement object -choices something
inherits FormElement
object configure
config
object build_form_element
config
object getf
args
object setf
value
object blank
# # multiple choices (radiobutton widgets) form element class # inherit FormElement method configure {config} {} method build_form_element {config} { set choiceNumber 0 upvar #0 $array myArray html_field_description "$text" foreach choice $choices { set checked "" if {$myArray($name) == $choice} { set checked " checked" } html "<input type=\"radio\" name=\"$array:$name\" value=\"$choice\"$checked> $choice" } html "\n" } method getf {args} { global $array return [set ${array}($name)] } method setf {value} { global $array set ${array}($name) $value return } method blank {} { setf "" } public choices
FormElement - an [incr tcl] class
FormElement object -array something -text something -form something -name something -errorwidget {} -labelWidth 20
inherits
object name
object build_table_field_description
config
object build_table_element
config
object error
object normal
# # generic form element class subclass # constructor {config} { global currentForm $currentForm add $this if ![info exists name] { error "-name must be specified" } if ![info exists text] { set text [translit "_" " " $name] } } destructor {} method name {} { return $name } # When outputting tables, this will output the field description # as the column header. method build_table_field_description {config} { html "<th>$text" } # When outputting tables, this will output the data corresponding # to the array element for this element as table data. # # Output a dot in empty fields to prevent netscape from # spanning them, which looks confusing. method build_table_element {config} { upvar #0 $array myArray if {[clength $myArray($name)] == 0} { html ". " } else { html "$myArray($name) " } } method error {} { if {$error == 1 || $errorwidget == ""} return set error 1 $errorwidget configure -background red } method normal {} { if {$error == 0 || $errorwidget == ""} return set error 0 $errorwidget configure -background [option get . background Tk] } protected error 0 public array public text public form public name public errorwidget "" public labelWidth 20
FormHiddenElement - an [incr tcl] class
FormHiddenElement object
inherits FormTextElement
object build_form_element
config
# # hidden element form element class # inherit FormTextElement method build_form_element {config} { upvar #0 $array myArray html "<input type=\"hidden\" name=\"$array:$name\" value=\"$myArray($name)\">" }
FormPasswordElement - an [incr tcl] class
FormPasswordElement object
inherits FormTextElement
object build_form_element
config
# # password element form element class # inherit FormTextElement method build_form_element {config} { upvar #0 $array myArray html_field_description $text html "<input type=\"password\" name=\"$array:$name\">\n" }
FormTextAreaElement - an [incr tcl] class
FormTextAreaElement object -rows 5 -cols 60
inherits FormTextElement
object build_form_element
config
# # text area element (entry widget) form element class # inherit FormTextElement method build_form_element {config} { upvar #0 $array myArray html "$text:\n" html "<textarea name=\"$array:$name\" rows=$rows cols=$cols>$myArray($name)\n" } public rows 5 public cols 60
FormTextElement - an [incr tcl] class
FormTextElement object -width 30
inherits FormElement
object configure
config
object build_form_element
config
object getf
object setf
value
object blank
# # text element (entry widget) form element class # inherit FormElement method configure {config} {} destructor { catch {unset lastElementCreated($form)} catch {unset firstElementCreated($form)} } method build_form_element {config} { upvar #0 $array myArray html_field_description $text html "<input type=\"text\" name=\"$array:$name\" value=\"$myArray($name)\">\n" } method getf {} { global $array return [set ${array}($name)] } method setf {value} { global $array set ${array}($name) $value } method blank {} { setf "" } protected widget common lastElementCreated common firstElementCreated public width 30
WebForm - an [incr tcl] class
WebForm object -namesToObjects something -elementNames {}
inherits
object screen_to_array
arrayName
object array_to_screen
arrayName
object boolean
name args
object text
name args
object hidden
name args
object password
name args
object choices
name args
object textarea
name args
object emit_form
args
object start_table
args
object emit_table_record
args
object end_table
object access_object
name args
object normal
object blank
object add
elementName
# # form superclass # constructor {config} { global currentForm set currentForm $this } destructor { foreach element $elementNames { $element delete } } method screen_to_array {arrayName} { upvar $arrayName array foreach element $elementNames { set array([$element name]) [$element getf] } } method array_to_screen {arrayName} { upvar $arrayName array foreach element $elementNames { $element setf $array([$element name]) } } method boolean {name args} { set object [eval FormBooleanElement #auto -form $this -name $name $args] set namesToObjects($name) $object } method text {name args} { set object [eval FormTextElement #auto -form $this -name $name $args] set namesToObjects($name) $object } method hidden {name args} { set object [eval FormHiddenElement #auto -form $this -name $name $args] set namesToObjects($name) $object } method password {name args} { set object [eval FormPasswordElement #auto -form $this -name $name $args] set namesToObjects($name) $object } method choices {name args} { set object [eval FormChoicesElement #auto -form $this -name $name $args] set namesToObjects($name) $object } method textarea {name args} { set object [eval FormTextAreaElement #auto -form $this -name $name $args] set namesToObjects($name) $object } method emit_form {args} { html "<form>" foreach element $elementNames { eval $element build_form_element $args } html "" html "" } method start_table {args} { html "
cgi_import_form
cgi_import_form argArrayName argTypeArrayName responseArrayName
upvar $argArrayName ar upvar $argTypeArrayName artype upvar $responseArrayName response global env set bigarg "" #join words with +'s if [info exists env(PATH_INFO)] { set args [split [crange $env(PATH_INFO) 1 end] /] } else { set args {} } if [info exists env(QUERY_STRING)] { set bigarg [split $env(QUERY_STRING) &] } else { set bigarg {} } foreach arg [concat $bigarg $args] { if [regexp {(.*)=(.*)} $arg foo name value] { set name [cgi_subhex $name] if ![info exists argcount($name)] { set argcount($name) 1 } else { incr argcount($name) } } } #split assignments on the '&' foreach arg [concat $bigarg $args] { if [regexp {(.*)=(.*)} $arg foo name value] { regsub -all {\+} $value { } newval set name [cgi_subhex $name] set val [cgi_subhex $newval] if ![info exists ar($name)] { if [info exists artype($name)] { if {$artype($name)=="list"} { if {$val!=""} { set ar($name) [list $val] } else { set ar($name) {} } } else { set ar($name) $val } } else { set ar($name) $val } } else { # multiple selection lappend ar($name) $val } } } if [info exists env(CONTENT_LENGTH)] { set message [split [read stdin $env(CONTENT_LENGTH)] &] foreach pair $message { lassign [split $pair =] name val regsub -all {\+} [cgi_subhex $val] { } val set response($name) $val } }
cgi_pkg_attrs
cgi_pkg_attrs var attrs
#makes URL extended pathname to encode current state upvar $var ar set al "" foreach i $attrs { if [info exists ar($i)] { regsub { } $ar($i) {+} att set al "$al/$i=$att" } } return $al
cgi_subhex
cgi_subhex v
#@package: www_cgi_interface cgi_import_form neo_cgi_import_form # # Copyright (C) 1992-1997 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # $Id: neo-www.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # Hoarked around from web-found tcl-proc-args.tar.Z #arguments are passed on command line. '&' separates assignments #assignments have the form name=value #'+'s are spaces and spaces separating words on command line are #actually part of the word #In our environment, if argument starts with /, then pathname #components are assignments # global variable artype(i) defines what type ar(i) should be. Currently, # list or not. set nv $v while {[regexp {%[0-9A-Fa-f][0-9A-Fa-f]} $v blah]} { scan $blah "%%%x" cv if {[ctype char $cv]=="&"} { regsub -all $blah $v \\& nv } else { regsub -all $blah $v [ctype char $cv] nv } set v $nv } return $v
html
html stuff
#@package: iwebforms IWebForm # # Web-based forms manager class library # by Karl Lehenbauer # # Copyright (C) 1993-1997 NeoSoft, All Rights Reserved # # # $Id: neo-www.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # # emit some html stuff # puts stdout $stuff nonewline
html_field_description
html_field_description text
# # emit an html form field description. we do it in one place # to make changing the appearance for all of the fields easy # html "[format %15s $text] "
neo_cgi_import_form
neo_cgi_import_form argArrayName argTypeArrayName responseArrayName {fieldOrderVarName ""}
upvar $argArrayName ar upvar $argTypeArrayName artype upvar $responseArrayName response if {$fieldOrderVarName != ""} {upvar $fieldOrderVarName fieldOrder} set fieldOrder "" global env set bigarg "" #join words with +'s if [info exists env(PATH_INFO)] { set args [split [crange $env(PATH_INFO) 1 end] /] } else { set args {} } if [info exists env(QUERY_STRING)] { set bigarg [split $env(QUERY_STRING) &] } else { set bigarg {} } foreach arg [concat $bigarg $args] { if [regexp {(.*)=(.*)} $arg foo name value] { set name [www_unescape_string $name] if ![info exists argcount($name)] { set argcount($name) 1 } else { incr argcount($name) } } } #split assignments on the '&' foreach arg [concat $bigarg $args] { if [regexp {(.*)=(.*)} $arg foo name value] { regsub -all {\+} $value { } newval set name [www_unescape_string $name] lappend fieldOrder $name set val [www_unescape_string $newval] if ![info exists ar($name)] { if [info exists artype($name)] { if {$artype($name)=="list"} { if {$val!=""} { set ar($name) [list $val] } else { set ar($name) {} } } else { set ar($name) $val } } else { set ar($name) $val } } else { # multiple selection lappend ar($name) $val } } } if [info exists env(CONTENT_LENGTH)] { set message [split [read stdin $env(CONTENT_LENGTH)] &] foreach pair $message { lassign [split $pair =] name val set response($name) [www_unescape_string $val] lappend fieldOrder $name } }