Table of Contents

FormBooleanElement
FormChoicesElement
FormElement
FormHiddenElement
FormPasswordElement
FormTextAreaElement
FormTextElement
WebForm
cgi_import_form
cgi_pkg_attrs
cgi_subhex
html
html_field_description
neo_cgi_import_form


[next] [TOC]

Command

FormBooleanElement - an [incr tcl] class

Synopsis

FormBooleanElement object

inherits FormElement

object configure config
object build_form_element config
object getf args
object setf value
object blank

Description

#
# 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 ""
    }

[next] [prev] [TOC]

Command

FormChoicesElement - an [incr tcl] class

Synopsis

FormChoicesElement object -choices something

inherits FormElement

object configure config
object build_form_element config
object getf args
object setf value
object blank

Description

#
# 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

[next] [prev] [TOC]

Command

FormElement - an [incr tcl] class

Synopsis

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

Description

#
# 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

[next] [prev] [TOC]

Command

FormHiddenElement - an [incr tcl] class

Synopsis

FormHiddenElement object

inherits FormTextElement

object build_form_element config

Description

#
# 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)\">"
    }

[next] [prev] [TOC]

Command

FormPasswordElement - an [incr tcl] class

Synopsis

FormPasswordElement object

inherits FormTextElement

object build_form_element config

Description

#
# 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"
    }

[next] [prev] [TOC]

Command

FormTextAreaElement - an [incr tcl] class

Synopsis

FormTextAreaElement object -rows 5 -cols 60

inherits FormTextElement

object build_form_element config

Description

#
# 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

[next] [prev] [TOC]

Command

FormTextElement - an [incr tcl] class

Synopsis

FormTextElement object -width 30

inherits FormElement

object configure config
object build_form_element config
object getf
object setf value
object blank

Description

#
# 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

[next] [prev] [TOC]

Command

WebForm - an [incr tcl] class

Synopsis

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

Description

#
# 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 "" foreach element $elementNames { eval $element build_table_field_description $args } html "\n" } method emit_table_record {args} { html "" foreach element $elementNames { eval $element build_table_element $args } html "\n" } method end_table {} { html "
\n" } method access_object {name args} { eval $namesToObjects($name) $args } method normal {} { foreach element $elementNames { $element normal } } method blank {} { foreach element $elementNames { $element blank } normal } method add {elementName} { lappend elementNames $elementName } public namesToObjects public elementNames "" global currentForm

[next] [prev] [TOC]

Command

cgi_import_form

Synopsis

cgi_import_form argArrayName argTypeArrayName responseArrayName

Description



    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
        }
    }

[next] [prev] [TOC]

Command

cgi_pkg_attrs

Synopsis

cgi_pkg_attrs var attrs

Description

#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

[next] [prev] [TOC]

Command

cgi_subhex

Synopsis

cgi_subhex v

Description

#@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

[next] [prev] [TOC]

Command

html

Synopsis

html stuff

Description

#@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

[next] [prev] [TOC]

Command

html_field_description

Synopsis

html_field_description text

Description

#
# 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]  "

[prev] [TOC]

Command

neo_cgi_import_form

Synopsis

neo_cgi_import_form argArrayName argTypeArrayName responseArrayName {fieldOrderVarName ""}

Description



    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
        }
    }