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.2 1998/01/06 18:58:45 kunkee 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.2 1998/01/06 18:58:45 kunkee 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
}
}