1: # form.tcl -- generate forms automatically. 2: 3: # Copyright 2002-2004 The Apache Software Foundation 4: 5: # Licensed under the Apache License, Version 2.0 (the "License"); 6: # you may not use this file except in compliance with the License. 7: # You may obtain a copy of the License at 8: 9: # http://www.apache.org/licenses/LICENSE-2.0 10: 11: # Unless required by applicable law or agreed to in writing, software 12: # distributed under the License is distributed on an "AS IS" BASIS, 13: # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 14: # See the License for the specific language governing permissions and 15: # limitations under the License. 16: 17: 18: package require Itcl 19: 20: package provide form 1.0 21: 22: # 23: # Rivet form class 24: # 25: ::itcl::class form { 26: 27: constructor {args} { 28: # set the form method to be a post and the action to be 29: # a refetching of the current page 30: set arguments(method) post 31: set arguments(action) [env DOCUMENT_URI] 32: 33: # use $this for the type for form-global stuff like form arguments 34: import_data form $this arguments $args 35: 36: if {[info exists arguments(defaults)]} { 37: upvar 1 $arguments(defaults) defaults 38: array set DefaultValues [array get defaults] 39: unset arguments(defaults) 40: } 41: } 42: 43: destructor { 44: 45: } 46: 47: method destroy {} { 48: ::itcl::delete object $this 49: } 50: 51: # 52: # import_data -- given a field type, field name, name of an array, and a 53: # list of key-value pairs, prepend any default key-value pairs, 54: # set a default value if one exists, then store the resulting 55: # key-value pairs in the named array 56: # 57: protected method import_data {type name arrayName list} { 58: upvar 1 $arrayName data 59: 60: # 61: # If there are elements in the defaultArgs array for the 62: # specified type, combine them with the list of key-value 63: # pairs, putting the DefaultArgs values first so the 64: # key-value pairs from list can possibly override them. 65: # 66: if {[info exists DefaultArgs($type)]} { 67: set list [concat $DefaultArgs($type) $list] 68: } 69: 70: # 71: # if there is a default value for the name stored in the 72: # DefaultValues array in this class, set the value 73: # element of the array the caller named to contain that 74: # value 75: # 76: if {[info exists DefaultValues($name)]} { 77: set data(value) $DefaultValues($name) 78: } 79: 80: # 81: # if we don't have an even number of key-value pairs, 82: # that just ain't right 83: # 84: if {[expr [llength $list] % 2]} { 85: return -code error "Unmatched key-value pairs" 86: } 87: 88: # 89: # for each key-value pair in the list, strip the first 90: # dash character from the key part and map it to lower 91: # case, then use that as the key for the passed-in 92: # array and store the corresonding value in there 93: # 94: # we also prep and return the list of key-value pairs, normalized 95: # with the lowercase thing 96: # 97: set return "" 98: foreach {var val} $list { 99: set var [string range [string tolower $var] 1 end] 100: set data($var) $val 101: if {$var == "values"} { continue } 102: lappend return -$var $val 103: } 104: return $return 105: } 106: 107: # 108: # argstring - given an array name, construct areturn string of the 109: # style key1="data1" key2="data2" etc for each key value pair in the 110: # array 111: # 112: protected method argstring {arrayName} { 113: upvar 1 $arrayName data 114: set string "" 115: foreach arg [lsort [array names data]] { 116: append string " $arg=\"$data($arg)\"" 117: } 118: return $string 119: } 120: 121: # 122: # default_value -- if only a name is given, returns a default value 123: # for that name if one exists else an empty list. 124: # 125: # if a name and a value are given, the default value is set to that 126: # name (and the new default value is returned). 127: # 128: method default_value {name {newValue ""}} { 129: if {[lempty $newValue]} { 130: if {![info exists DefaultValues($name)]} { return } 131: return $DefaultValues($name) 132: } 133: return [set DefaultValues($name) $newValue] 134: } 135: 136: # 137: # default_args - given a type and a variable number of arguments, 138: # if there are no arguments other than the type, return the 139: # element of that name from the DefaultArgs array, if that element 140: # exists, else return an empty list. 141: # 142: # if a name and a value are given, sets the DefaultArgs to the variable 143: # list of arguments. 144: # 145: method default_args {type args} { 146: 147: # if only one argument was specified 148: if {[lempty $args]} { 149: if {![info exists DefaultArgs($type)]} { return } 150: return $DefaultArgs($type) 151: } 152: 153: # make sure we have an even number of key-value pairs 154: if {[expr [llength $args] % 2]} { 155: return -code error "Unmatched key-value pairs" 156: } 157: 158: # set the DefaultArgs for the specified type 159: return [set DefaultArgs($type) $args] 160: } 161: 162: # 163: # start - generate the <form> with all of its arguments 164: # 165: method start {{args ""}} { 166: if {![lempty $args]} { 167: # replicated in constructor 168: import_data form $this arguments $args 169: } 170: html "<form [argstring arguments]>" 171: } 172: 173: # 174: # end - generate the </form> 175: # 176: method end {} { 177: html "</form>" 178: } 179: 180: # 181: # field - emit a field of the given field type and name, including 182: # any default key-value pairs defined for this field type and 183: # optional key-value pairs included with the statement 184: # 185: method field {type name args} { 186: 187: # import any default key-value pairs, then any specified in this 188: # field declaration 189: import_data $type $name data $args 190: 191: # generate the field definition 192: set string "<input type=\"$type\" name=\"$name\"" 193: append string [argstring data] 194: 195: switch -- $type { 196: "radio" - 197: "checkbox" { 198: # if there's no value defined, create an empty value 199: if {![info exists data(value)]} { 200: set data(value) "" 201: } 202: 203: # if there's no label defined, make the label be the 204: # same as the value 205: if {![info exists data(label)]} { 206: set data(label) $data(value) 207: } 208: 209: # ...and if the is a default value for this field 210: # and it matches the value we have for it, make 211: # the field show up as selected (checked) 212: if {[info exists DefaultValues($name)]} { 213: if {$data(value) == $DefaultValues($name)} { 214: append string { checked="checked"} 215: } 216: } 217: } 218: } 219: append string " />" 220: 221: # ...and emit it 222: if {$type == "radio"} { 223: html $string$data(label) 224: } else { 225: html $string 226: } 227: } 228: 229: # 230: # text -- emit an HTML "text" field 231: # 232: method text {name args} { 233: eval field text $name $args 234: } 235: 236: # 237: # password -- emit an HTML "password" field 238: # 239: method password {name args} { 240: eval field password $name $args 241: } 242: 243: # 244: # hidden -- emit an HTML "hidden" field 245: # 246: method hidden {name args} { 247: eval field hidden $name $args 248: } 249: 250: # 251: # submit -- emit an HTML "submit" field 252: # 253: method submit {name args} { 254: eval field submit $name $args 255: } 256: 257: # 258: # reset -- emit an HTML "reset" button 259: # 260: method reset {name args} { 261: eval field reset $name $args 262: } 263: 264: # 265: # reset -- emit an HTML image field 266: # 267: method image {name args} { 268: eval field image $name $args 269: } 270: 271: # 272: # reset -- emit an HTML "checkbox" form field 273: # 274: method checkbox {name args} { 275: eval field checkbox $name $args 276: } 277: 278: # 279: # radio -- emit an HTML "radiobutton" form field 280: # 281: method radio {name args} { 282: eval field radio $name $args 283: } 284: 285: # 286: # radiobuttons -- 287: # 288: method radiobuttons {name args} { 289: set data(values) [list] 290: set data(labels) [list] 291: 292: set list [import_data radiobuttons $name data $args] 293: 294: if {[lempty $data(labels)]} { 295: set data(labels) $data(values) 296: } 297: 298: foreach label $data(labels) value $data(values) { 299: eval radio $name $list -label $label -value $value 300: } 301: } 302: 303: # 304: # select -- generate a selector 305: # 306: # part of the key value pairs can include -values with a list, 307: # and -labels with a list and it'll populate the <option> 308: # elements with them. if one matches the default value, 309: # it'll select it too. 310: # 311: method select {name args} { 312: # start with empty values and labels so they'll exist even if not set 313: set data(values) [list] 314: set data(labels) [list] 315: 316: # import any default data and key-value pairs from the method args 317: import_data select $name data $args 318: 319: # pull the values and labels into scalar variables and remove them 320: # from the data array 321: set values $data(values) 322: set labels $data(labels) 323: unset data(values) data(labels) 324: 325: # get the default value, use an empty string if there isn't one 326: set default "" 327: if {[info exists DefaultValues($name)]} { 328: set default $DefaultValues($name) 329: } 330: 331: # if there is a value set in the value field of the data array, 332: # use that instead (that way if we're putting up a form with 333: # data already, the data'll show up) 334: if {[info exists data(value)]} { 335: set default $data(value) 336: unset data(value) 337: } 338: 339: # 340: # if there are no separate labels defined, use the list of 341: # values for the labels 342: # 343: if {[lempty $labels]} { 344: set labels $values 345: } 346: 347: # emit the selector 348: html "<select name=\"$name\" [argstring data]>" 349: 350: # emit each label-value pair 351: foreach label $labels value $values { 352: if {$value == $default} { 353: set string "<option value=\"$value\" selected=\"selected\">" 354: } else { 355: set string "<option value=\"$value\">" 356: } 357: html $string$label 358: } 359: html "</select>" 360: } 361: 362: # 363: # textarea -- emit an HTML "textarea" form field 364: # 365: method textarea {name args} { 366: import_data textarea $name data $args 367: set value "" 368: if {[info exists data(value)]} { 369: set value $data(value) 370: unset data(value) 371: } 372: html "<textarea name=\"$name\" [argstring data]>$value</textarea>" 373: } 374: 375: # 376: # defaults -- when set, the value is the name of an array to suck 377: # the key-value pairs out of and copy them into DefaultValues 378: # 379: public variable defaults "" { 380: upvar 1 $defaults array 381: array set DefaultValues [array get array] 382: } 383: 384: private variable DefaultValues 385: private variable DefaultArgs 386: 387: private variable arguments 388: 389: } ; ## ::itcl::class form |