Posted to tcl by marc.ziegenhagen at Thu Nov 18 12:12:24 GMT 2010view raw

  1. # 20100930/mz no label for hidden fields
  2. # 20100930/mz Readonly shows only text
  3. # Form.html
  4. # this is an experiment in constructing forms.
  5. #
  6. # adds:
  7. #
  8. # Grouping and Labelling:
  9. # <form> id {attrs} content
  10. # <fieldset> id {attrs} content
  11. # Group content into forms/fieldsets - content is evaluated
  12. #
  13. # <legend> {attrs} content
  14. # provide a legend - useful in fieldsets
  15.  
  16. # Menus
  17. # <select> name {attrs} content
  18. # <option> {attrs} value
  19. # <optgroup> {attrs} value
  20. #
  21. # select menus. content and value are evaluated.
  22.  
  23. # Input Fields
  24. # <password> name {attrs} value
  25. # <text> name {attrs} value
  26. # <hidden> name {attrs} value
  27. # <file> name {attrs} value
  28. # <image> name {attrs} src
  29. # <textarea> name {attrs} content
  30. # <button> name {attrs} content
  31. # <reset> name {attrs} content
  32. # <submit> name {attrs} content
  33. # <radio> name {attrs} text
  34. # <checkbox> name {attrs} text
  35. #
  36. # input boxes - content/value/text are evaluated
  37.  
  38. # Sets - radio and checkboxes in groups
  39. # <radioset> name {attrs} content
  40. # <checkset> name {attrs} content
  41. # <selectset> name {attrs} content
  42. #
  43. # Sets group together radioboxes, checkboxes and selects into a single coherent unit.
  44. # each content is assumed to be a list of name/value pairs
  45.  
  46. if {[info exists argv0] && ([info script] eq $argv0)} {
  47. lappend auto_path [file dirname [file normalize [info script]]] ../Utilities/ ../extensions/
  48. }
  49.  
  50. package require textutil
  51. package require Dict
  52. package require Html
  53. package require OO
  54.  
  55. package require Debug
  56. Debug define form 10
  57.  
  58. package provide Form 2.0
  59.  
  60. set ::API(Utilities/Form) {
  61. {
  62. HTML Form generator
  63. }
  64. }
  65.  
  66. class create ::FormClass {
  67. # default - set attribute defaults for a given tag
  68. method setdefaults {type args} {
  69. variable Fdefaults
  70. dict Fdefaults.$type [dict merge [dict Fdefaults.$type] $args]
  71. }
  72. method setdefault {type args} {
  73. variable Fdefaults
  74. dict set Fdefaults $type {*}$args
  75. }
  76.  
  77. method defaults {type args} {
  78. if {[llength $args] == 1} {
  79. set args [lindex $args 0]
  80. }
  81.  
  82. variable Fdefaults
  83. Debug.form {defaults '$type' ($args) [dict Fdefaults.$type?]}
  84. set class {}
  85. foreach {n v} $args {
  86. if {$n eq "class"} {
  87. # merge elements of class, not the whole class
  88. Debug.form {defaults '$type' class merge ($v) ()}
  89. lappend class {*}[split $v]
  90. }
  91. }
  92.  
  93. set class [list {*}$class {*}[dict Fdefaults.$type.class?]]
  94. if {[llength $class]} {
  95. set class [list class $class]
  96. } else {
  97. set class {}
  98. }
  99.  
  100. set result [dict merge [dict Fdefaults.$type?] $args $class]
  101. Debug.form {defaults '$type' -> $result}
  102. return $result
  103. }
  104.  
  105. # gather options from args
  106. method attr {tag args} {
  107. if {[llength $args]==1} {
  108. set args [lindex $args 0]
  109. }
  110. Debug.form {attr: $tag ($args)}
  111.  
  112. set opts {}
  113. foreach {n v} $args {
  114. set n [string trim $n]
  115. if {[string match -* $n]} continue
  116. if {$n eq "class"} {
  117. # aggregate class args
  118. foreach c [split [string trim $v]] {
  119. if {$c ne {}} {
  120. dict lappend opts class $c
  121. }
  122. }
  123. } else {
  124. dict set opts $n [armour [string trim $v]]
  125. }
  126. }
  127.  
  128. set attrs $tag
  129. foreach {n v} $opts {
  130. if {$n in {checked disabled selected noshade}} {
  131. if {$v} {
  132. lappend attrs $n ;# flagg attribute
  133. }
  134. } elseif {![info exists seen($n)]} {
  135. lappend attrs "$n='$v'"
  136. }
  137. }
  138.  
  139. return [join $attrs]
  140. }
  141.  
  142. method fieldsetS {name args} {
  143. variable fieldsetA
  144. set config [my defaults fieldset [lrange $args 0 end-1]]
  145. if {![dict exists $config id]} {
  146. if {$name ne ""} {
  147. dict config.id $name
  148. } else {
  149. variable uniqID
  150. dict config.id F[incr uniqID]
  151. }
  152. }
  153. set content "<[my attr fieldset {*}[dict in $config $fieldsetA] {*}[dict filter $config key data-*]]>\n"
  154. if {[dict exists $config legend]} {
  155. append content [my <legend> [dict config.legend]] \n
  156. }
  157. return $content
  158. }
  159.  
  160. method formS {name args} {
  161. variable formA
  162. variable tabindex 0
  163. set config [my defaults form [lrange $args 0 end-1]]
  164. if {![dict exists $config id]} {
  165. if {$name ne ""} {
  166. dict config.id $name
  167. } else {
  168. variable uniqID
  169. dict config.id F[incr uniqID]
  170. }
  171. }
  172. set content "<[my attr form {*}[dict in $config $formA] {*}[dict filter $config key data-*]]>\n"
  173. if {[dict exists $config legend]} {
  174. append content [my <legend> [dict config.legend]] \n
  175. }
  176. return $content
  177. }
  178.  
  179. # <form> and <fieldset>
  180. foreach {type} {form fieldset} {
  181. if {$type eq "form"} {
  182. set ti {
  183. variable tabindex 0
  184. }
  185. } else {
  186. set ti ""
  187. }
  188.  
  189. eval [string map [list %TI% $ti %T% $type] {
  190. method <%T%> {args} {
  191. variable %T%A
  192. variable metadata {}
  193.  
  194. set body [lindex $args end]
  195. set args [lrange $args 0 end-1]
  196.  
  197. Debug.form {[self] defining %T% over ($body) with ($args)}
  198.  
  199. # get form name from args, if present
  200. set name ""
  201. if {[llength $args]%2} {
  202. set args [lassign $args name]
  203. }
  204.  
  205. set config [my defaults %T% $args]
  206. %TI%
  207.  
  208. my metadata $name $config
  209.  
  210. # ensure an id
  211. if {![dict exists $config id]} {
  212. if {$name ne ""} {
  213. dict config.id $name
  214. } else {
  215. variable uniqID
  216. dict config.id F[incr uniqID]
  217. }
  218. }
  219.  
  220. if {![dict exists $config -raw] || ![dict get $config -raw]} {
  221. # evaluate form content
  222. set body [uplevel 1 [list subst $body]]
  223. } else {
  224. # don't evaluate form content
  225. dict unset config -raw
  226. }
  227. set body [string trim $body " \t\n\r"]
  228.  
  229. set content ""
  230. if {[dict exists $config legend]} {
  231. append content [my <legend> [dict config.legend]] \n
  232. }
  233. append content $body
  234. set vertical [dict config.vertical?]
  235. if {$vertical ne "" && $vertical} {
  236. set content [string map {\n <br>\n} $content]
  237. }
  238.  
  239. return "<[my attr %T% {*}[dict in $config $%T%A] {*}[dict filter $config key data-*]]>$content</%T%>"
  240. }
  241. }]
  242. }
  243.  
  244. # process or return metadata
  245. method metadata {{name ""} {config ""}} {
  246. variable metadata
  247. if {$name eq ""} {
  248. return $metadata ;# want all metadata
  249. }
  250.  
  251. if {$config eq ""} {
  252. return [dict metadata.$name?] ;# want metadata for field
  253. }
  254.  
  255. set n $name; set i 0
  256. while {[dict exists $metadata $n]} {
  257. # ensure metadata is unique by name
  258. set n ${name}_[incr i]
  259. }
  260.  
  261. Debug.form {[self] metadata '$n': $config}
  262. dict metadata.$n $config
  263. }
  264.  
  265. foreach {type} {legend} {
  266. eval [string map [list %T% $type] {
  267. method <%T%> {args} {
  268. variable %T%A
  269. set config [my defaults %T% [lrange $args 0 end-1]]
  270. return "<[my attr %T% {*}[dict in $config $%T%A] {*}[dict filter $config key data-*]]>[uplevel 1 [list subst [lindex $args end]]]</%T%>"
  271. }
  272. }]
  273. }
  274.  
  275. method <select> {name args} {
  276. variable selectA
  277.  
  278. set content [lindex $args end]
  279. set args [lrange $args 0 end-1]
  280. set config [my defaults select {*}$args name $name]
  281.  
  282. if {![dict exists $config id]} {
  283. dict config.id $name
  284. }
  285. set id [dict config.id]
  286.  
  287. if {![dict exists $config tabindex]} {
  288. variable tabindex
  289. dict config.tabindex [incr tabindex]
  290. }
  291.  
  292. set content [uplevel 1 [list subst $content]]
  293.  
  294. my metadata $name $config ;# remember config for field
  295. set result "<[my attr select {*}[dict in $config $selectA] {*}[dict filter $config key data-*]]>$content</select>"
  296.  
  297. if {[dict exists $config title]} {
  298. set title [list title [dict config.title]]
  299. } else {
  300. set title {}
  301. }
  302.  
  303. set label [dict config.label?]
  304. if {$label ne ""} {
  305. return "[my <label> for $id $label] $result"
  306. } elseif {[dict exists $config legend]} {
  307. set legend [dict config.legend]
  308.  
  309. # get sub-attributes of form "{subel attr} value"
  310. set sattr {fieldset {} legend {}}
  311. dict for {k v} $config {
  312. set k [split $k]
  313. if {[llength $k] > 1} {
  314. dict sattr.[lindex $k 0].[lindex $k 1] $v
  315. }
  316. }
  317.  
  318. return [my <fieldset> "" {*}[dict sattr.fieldset] {*}$title {
  319. [my <legend> {*}[dict sattr.legend] $legend]
  320. $result
  321. }]
  322. } else {
  323. return $result
  324. }
  325. }
  326.  
  327. foreach {type} {option optgroup} {
  328. eval [string map [list %T% $type] {
  329. method <%T%> {args} {
  330. variable %T%A
  331.  
  332. if {[llength $args]%2} {
  333. set content [lindex $args end]
  334. set args [lrange $args 0 end-1]
  335. } else {
  336. set content ""
  337. }
  338. set config [my defaults %T% $args]
  339.  
  340. if {![dict exists $config value]} {
  341. dict set config value $content
  342. }
  343. if {$content eq ""} {
  344. set content [dict config.value]
  345. } else {
  346. set content [uplevel 1 [list subst $content]]
  347. }
  348.  
  349. if {[dict exist $config select?]} {
  350. if {[dict get $config select?] eq [dict config.value]} {
  351. dict config.selected 1
  352. }
  353. }
  354.  
  355. return "<[my attr %T% {*}[dict in $config $%T%A] {*}[dict filter $config key data-*]]>$content</%T%>"
  356. }
  357. }]
  358. }
  359.  
  360. method <textarea> {name args} {
  361. variable textareaA
  362. if {[llength $args] % 2} {
  363. set content [lindex $args end]
  364. set args [lrange $args 0 end-1]
  365. } else {
  366. set content ""
  367. }
  368. set config [my defaults textarea {*}$args name $name]
  369.  
  370. if {![dict exists $config tabindex]} {
  371. variable tabindex
  372. dict config.tabindex [incr tabindex]
  373. }
  374.  
  375. # ensure an id
  376. if {![dict exists $config id]} {
  377. dict config.id $name
  378. }
  379. set id [dict config.id]
  380.  
  381. if {[dict exists $config compact]} {
  382. if {[dict config.compact]} {
  383. # remove initial spaces from Form
  384. set content [::textutil::undent [::textutil::untabify $content]]
  385. }
  386. dict unset config compact
  387. }
  388.  
  389. set title {}
  390. if {[dict exists $config title]
  391. && ([dict exists $config label]
  392. || [dict exists $config legend])
  393. } {
  394. set title [list title $title]
  395. dict unset config title
  396. }
  397.  
  398. my metadata $name $config ;# remember config for field
  399. set result "<[my attr textarea {*}[dict in $config $textareaA] {*}[dict filter $config key data-*]]>$content</textarea>"
  400.  
  401. set label [dict config.label?]
  402. if {$label ne ""} {
  403. return "[my <label> for $id $label] $result"
  404. } elseif {[dict exists $config legend]} {
  405. set legend [dict config.legend]
  406.  
  407. # get sub-attributes of form "{subel attr} value"
  408. set sattr {fieldset {} legend {}}
  409. dict for {k v} $config {
  410. set k [split $k]
  411. if {[llength $k] > 1} {
  412. dict sattr.[lindex $k 0].[lindex $k 1] $v
  413. }
  414. }
  415.  
  416. return [my <fieldset> "" {*}[dict sattr.fieldset] {*}$title {
  417. [my <legend> {*}[dict sattr.legend] $legend]
  418. $result
  419. }]
  420. } else {
  421. return $result
  422. }
  423. }
  424.  
  425. # <reset> and <submit>
  426. foreach type {reset submit} {
  427. eval [string map [list %T% $type] {
  428. method <%T%> {name args} {
  429. if {[llength $args] % 2} {
  430. set content [lindex $args end]
  431. set args [lrange $args 0 end-1]
  432. } else {
  433. set content ""
  434. }
  435. set config [my defaults %T% alt %T% {*}$args name $name type %T%]
  436.  
  437. if {![dict exists $config tabindex]} {
  438. variable tabindex
  439. dict config.tabindex [incr tabindex]
  440. }
  441.  
  442. if {$content eq {}} {
  443. if {[dict exists $config content]} {
  444. set content [dict config.content]
  445. } else {
  446. set content [string totitle %T%]
  447. }
  448. } else {
  449. set content [uplevel 1 subst [list $content]]
  450. }
  451.  
  452. my metadata $name $config ;# remember config for field
  453. variable imageA
  454. return [my <button> $name {*}$config $content]
  455. }
  456. }]
  457. }
  458.  
  459. method <button> {name args} {
  460. if {[llength $args]%2} {
  461. set content [lindex $args end]
  462. set args [lrange $args 0 end-1]
  463. } else {
  464. set content ""
  465. }
  466. set config [my defaults button {*}$args name $name]
  467.  
  468. if {![dict exists $config tabindex]} {
  469. variable tabindex
  470. dict config.tabindex [incr tabindex]
  471. }
  472.  
  473. my metadata $name $config ;# remember config for field
  474. variable buttonA
  475. return "<[my attr button {*}[dict in $config $buttonA] {*}[dict filter $config key data-*]]>$content</button>"
  476. }
  477.  
  478. foreach {itype attrs field} {
  479. password text value
  480. text text value
  481. hidden text value
  482. file file value
  483. image image src
  484. } {
  485. eval [string map [list %T% $itype %A% $attrs %F% $field] {
  486. method <%T%> {name args} {
  487. if {[llength $args]%2} {
  488. set value [lindex $args end]
  489. set args [lrange $args 0 end-1]
  490. } else {
  491. set value ""
  492. }
  493.  
  494. #20100920/mz
  495. set config [my defaults %T% readonly 0 {*}$args name $name type %T% %F% [uplevel 1 [list subst $value]]]
  496.  
  497. if {![dict exists $config tabindex]} {
  498. variable tabindex
  499. dict config.tabindex [incr tabindex]
  500. }
  501.  
  502. if {![dict exists $config id]} {
  503. dict config.id $name
  504. }
  505. set id [dict config.id]
  506.  
  507. # get sub-attributes of form "{subel attr} value"
  508. set sattr {label {} legend {}}
  509. dict for {k v} $config {
  510. set k [split $k]
  511. if {[llength $k] > 1} {
  512. dict sattr.[lindex $k 0].[lindex $k 1] $v
  513. }
  514. }
  515.  
  516. my metadata $name $config ;# remember config for field
  517. variable %A%A
  518. #20100920/mz
  519. set readonly [dict get? $config readonly]
  520. if {!$readonly} {
  521. dict unset config readonly
  522. }
  523. set result "<[my attr input {*}[dict in $config $%A%A] {*}[dict filter $config key data-*]]>"
  524.  
  525. set label [dict config.label?]
  526. #20100920/mz
  527. if {[dict get? $config type] == "hidden"} {
  528. return "$result"
  529. } elseif {$label ne ""} {
  530. set result "[my <label> for $id $label] $result"
  531. } elseif {[set legend [dict config.legend?]] ne ""} {
  532. set result "[my <span> {*}[dict sattr.legend] $legend] $result"
  533. }
  534.  
  535. Debug.form {[self] emit %T%: $result}
  536. return $result
  537. }
  538. }]
  539. }
  540.  
  541. method <selectlist> {name args} {
  542. set result ""
  543. foreach line [lindex $args end] {
  544. set line [string trim $line]
  545. if {$line eq ""} continue
  546. if {[string match +* $line]} {
  547. set term [list <option> selected 1 {*}[string trimleft $line +]]
  548. } else {
  549. set term [list <option> {*}$line]
  550. }
  551. append result \[ $term \] \n
  552. }
  553. return [uplevel 1 [list <select> $name {*}[lrange $args 0 end-1] $result]]
  554. }
  555.  
  556. method <selectset> {args} {
  557. return [uplevel 1 [list <selectlist> {*}$args]]
  558. }
  559.  
  560. # <radioset> <checkset> <radio> <checkbox>
  561. foreach type {radio check} sub {"" box} {
  562. eval [string map [list %T% $type %S% $sub] {
  563. method <%T%set> {name args} {
  564. set args [lassign $args boxes]
  565. set rsconfig [my defaults %T% {*}$args name $name type %T%]
  566. set result {}
  567.  
  568. set accum ""
  569. foreach {content value} $boxes {
  570. set config [my defaults %T%%S% {*}$rsconfig]
  571. if {[string match +* $content]} {
  572. dict config.checked 1
  573. set content [string trim $content +]
  574. } else {
  575. catch {dict unset config checked}
  576. }
  577. dict config.value $value
  578. lappend result [uplevel 1 [list <%T%%S%> $name {*}$config $content]]
  579. set accum ""
  580. }
  581.  
  582. if {[dict exists $rsconfig vertical]
  583. && [dict rsconfig.vertical]} {
  584. set joiner <br>
  585. } else {
  586. set joiner \n
  587. }
  588.  
  589. my metadata $name $config ;# remember config for field
  590.  
  591. if {[dict exists $rsconfig legend]} {
  592. set legend [dict rsconfig.legend]
  593.  
  594. # get sub-attributes of form "{subel attr} value"
  595. set sattr {fieldset {} legend {}}
  596. dict for {k v} $config {
  597. set k [split $k]
  598. if {[llength $k] > 1} {
  599. dict sattr.[lindex $k 0].[lindex $k 1] $v
  600. }
  601. }
  602.  
  603. return [my <fieldset> "" {*}[dict sattr.fieldset] {
  604. [my <legend> {*}[dict sattr.legend] $legend]
  605. [join $result $joiner]
  606. }]
  607. } else {
  608. return [join $result $joiner]
  609. }
  610. }
  611. }]
  612.  
  613. eval [string map [list %T% $type$sub] {
  614. method <%T%> {name args} {
  615. if {[llength $args] % 2} {
  616. set content [lindex $args end]
  617. set args [lrange $args 0 end-1]
  618. set content [uplevel 1 [list subst $content]]
  619. } else {
  620. set content ""
  621. }
  622.  
  623. set config [my defaults %T% {*}$args name $name type %T%]
  624.  
  625. if {![dict exists $config label] && $content ne ""} {
  626. # content is the default label
  627. dict config.label $content
  628. set content ""
  629. }
  630.  
  631. if {![dict exists $config tabindex]} {
  632. # assign a tabindex
  633. variable tabindex
  634. dict config.tabindex [incr tabindex]
  635. }
  636.  
  637. if {![dict exists $config id]} {
  638. # each element should have an id
  639. variable uniqID
  640. dict config.id F[incr uniqID]
  641. }
  642.  
  643. my metadata $name $config ;# remember config for field
  644.  
  645. set id [dict config.id]
  646. variable boxA
  647. set result "<[my attr input {*}[dict in $config $boxA] {*}[dict filter $config key data-*]]>$content"
  648.  
  649. if {[set label [dict config.label?]] ne ""} {
  650. # wrap element around with a label
  651. set lconfig [my defaults label]
  652. if {[dict exists $config title]} {
  653. return "[my <label> for $id title [dict config.title] {*}$lconfig $label] $result"
  654. } else {
  655. return "[my <label> for $id {*}$lconfig $label] $result"
  656. }
  657. } else {
  658. return $result
  659. }
  660. }
  661. }]
  662. }
  663.  
  664. # Toolbar from
  665. # http://www.filamentgroup.com/lab/styling_buttons_and_toolbars_with_the_jquery_ui_css_framework/
  666. method <icobutton> {icon url content {title ""}} {
  667. if {$title ne ""} {
  668. set title [list title $title]
  669. }
  670. set content [uplevel 1 [list subst $content]]
  671. return [<a> href $url class "fg-button ui-state-default fg-button-icon-solo ui-corner-all" {*}$title [<span> class "ui-icon ui-icon-$icon" {}]$content]
  672. }
  673. method <buttons> {args} {
  674. set result [string trim [uplevel 1 [list subst [join $args]]] \n]
  675. return [<div> class "fg-buttonset ui-helper-clearfix" $result]
  676. }
  677. method <multibuttons> {args} {
  678. set result [string trim [uplevel 1 [list subst [join $args]]] \n]
  679. return [<div> class "fg-buttonset fg-buttonset-multi" $result]
  680. }
  681. method <singlebuttons> {args} {
  682. set result [string trim [uplevel 1 [list subst [join $args]]] \n]
  683. return [<div> class "fg-buttonset fg-buttonset-single" $result]
  684. }
  685. method <toolbar> {id args} {
  686. set result [string trim [uplevel 1 [list subst [join $args]]] \n]
  687. return [<div> id $id class "fg-toolbar ui-widget-header ui-corner-all ui-helper-clearfix" $result]
  688. }
  689.  
  690. method layout_parser {fname args} {
  691. Debug.form {layout_parser: '$fname' ($args)}
  692. upvar 1 lmetadata lmetadata
  693. variable layoutcache
  694. if {[info exists layoutcache($fname-$args)]} {
  695. return $layoutcache($fname-$args)
  696. }
  697. if {[llength $args]%2 != 1} {
  698. error "syntax: layout name ?option_pairs? {content}"
  699. }
  700.  
  701. set script [lindex $args end]
  702. set args [lrange $args 0 end-1]
  703. set control [dict filter $args key -*] ;# these are control args
  704. set args [dict ni $args $control] ;# these are form args
  705.  
  706. variable tags
  707. package require parsetcl
  708. set parse [::parsetcl simple_parse_script $script]
  709.  
  710. set rendered {}
  711. set known {}
  712. set form {}
  713. set frag 0
  714.  
  715. parsetcl walk_tree parse index Cd {
  716. if {[llength $index] == 1} {
  717. # body
  718. set line [lindex $parse {*}$index]
  719. Debug.form {walk: '$line'}
  720. set cargs [lassign $line . . . left]
  721. set fc [lindex $left 2]
  722. if {[string match L* [lindex $left 0]] && $fc in $tags} {
  723. switch -- $fc {
  724. form {
  725. # use this command to inject args into eventual <form>
  726. foreach ca $cargs {
  727. lappend args [parsetcl unparse $ca]
  728. }
  729. }
  730.  
  731. fieldset {
  732. set name [lindex $cargs 0]
  733. if {[dict exists $known $name]} {
  734. error "redeclaration of '$name' in '[parsetcl unparse $line]'"
  735. }
  736.  
  737. set content [lindex $cargs end]
  738. set fsargs {}
  739. foreach ca [lrange $cargs 1 end-1] {
  740. lappend fsargs [parsetcl unparse $ca]
  741. }
  742. set name [string trim [lindex $name 2] .]
  743.  
  744. # a fieldset's content is itself a form - recursively parse
  745. set content [lindex $content 2]
  746. set fs [lindex [uplevel 1 [list [self] layout_parser $name {*}$control \n$content\n]] 1]
  747. set fs "\[[self] <fieldset> $name $fsargs [list \n$fs\n]\]"
  748. Debug.form {fieldset: name:'$name' content:'$content' -> ($fs)}
  749. dict known.$name \n$fs
  750. }
  751.  
  752. select {
  753. set name [lindex $cargs 0]
  754. if {[dict exists $known $name]} {
  755. error "redeclaration of '$name' in '[parsetcl unparse $line]'"
  756. }
  757.  
  758. set content [lindex $cargs end]
  759. set fsargs {}
  760. foreach ca [lrange $cargs 1 end-1] {
  761. lappend fsargs [parsetcl unparse $ca]
  762. }
  763. set fsargs [join $fsargs]
  764. set name [string trim [lindex $name 2] .]
  765.  
  766. # a select's content is itself a form - recursively parse
  767. set content [lindex $content 2]
  768. set fs [lindex [uplevel 1 [list [self] layout_parser $name \n$content\n]] 1]
  769. set fs "\[[self] <select> $name $fsargs [list \n$fs\n]\]"
  770. Debug.form {select: $name: '$content' -> ($fs)}
  771. dict known.$name \n$fs
  772. }
  773.  
  774. legend {
  775. lset parse {*}$index 3 2 <legend> ;# make it a form command
  776. set allargs {}
  777. foreach a $cargs { # body
  778. parsetcl walk_tree a li Cd {
  779. set lleft [lindex $a {*}$li 3]
  780. set sc [lindex $lleft 2]
  781. if {[string match L* [lindex $lleft 0]]
  782. && [string match <*> $sc]
  783. && [string trim $sc <>] in $tags
  784. } {
  785. Debug.form {legend subcommand: '$sc'}
  786. # this is a form <tag> command
  787. # rewrite it so it appears to be coming from [self]
  788. lset a {*}$li 3 2 [list [self] $sc]
  789. }
  790. }
  791. set up [parsetcl unparse $a]
  792. Debug.form {legend: $up}
  793. lappend allargs $up
  794. }
  795. dict known.[incr frag] "\[[self] <$fc> [join $allargs]\]"
  796. }
  797.  
  798. default {
  799. lset parse {*}$index 3 2 <$fc> ;# make it a form command
  800. set name [lindex $parse {*}$index 4 2]
  801. if {![string match L* [lindex $parse {*}$index 4 0]]} {
  802. error "'[lindex $parse {*}$index 4 2]' is not a name in [parsetcl unparse $line]"
  803. }
  804. if {[dict exists $known $name]} {
  805. error "redeclaration of '$name' in '[parsetcl unparse $line]'"
  806. }
  807.  
  808. set allargs {}
  809. foreach a $cargs {
  810. lappend allargs [parsetcl unparse $a]
  811. }
  812. if {[llength $allargs]%2} {
  813. # no content specified
  814. set content ""
  815. set allargs [lrange $allargs 1 end]
  816. } else {
  817. # content specified
  818. set content [lindex $allargs end]
  819. set allargs [lrange $allargs 1 end-1]
  820. }
  821.  
  822. set lmd [dict filter $allargs key -*]
  823. dict lmd.-content $content
  824. dict lmetadata.$name $lmd
  825. set allargs [dict ni $allargs $lmd]
  826. if {[dict control.-content?] ne ""} {
  827. set content \[[list {*}[dict control.-content] $name]\]
  828. }
  829. Debug.form {[self] argsplitting: $name ($allargs) / ($lmd)}
  830.  
  831. dict known.$name "\[[self] <$fc> $name [join $allargs] $content\]"
  832. }
  833. }
  834. } else {
  835. Debug.form {'$fc' is not a form tag}
  836. dict known.[incr frag] \[[parsetcl unparse $line]\]
  837. }
  838. } else {
  839. # this is a normal command within the body of a tag - leave it alone
  840. }
  841. } C.* {
  842. dict known.[incr frag] \[[parsetcl unparse $line]\]
  843. }
  844.  
  845. set result "$fname $args [list [join [dict values $known] \n]\n]"
  846. set layoutcache($fname-$args) $result
  847. return $result
  848. }
  849.  
  850. method layout {fname args} {
  851. set result [my layout_parser $fname {*}$args]
  852. Debug.form {[self] layout: ($result)}
  853. return [uplevel 1 [list [self] <form> {*}$result]]
  854. }
  855.  
  856. method <keygen> {name args} {
  857. return "<[my attr keygen name $name {*}$args]>"
  858. }
  859.  
  860. # return a HTML singleton tag
  861. foreach tag {img br hr} {
  862. method <$tag> {args} [string map [list %T $tag] {
  863. if {$::Html::XHTML} {
  864. set suff /
  865. } else {
  866. set suff ""
  867. }
  868. return "<[Html::attr %T {*}$args]${suff}>"
  869. }]
  870. }
  871.  
  872. method unknown {cmd args} {
  873. if {![string match <*> $cmd]} {
  874. error "Unknown method '$cmd' in [self] of class [info object class [self]]"
  875. }
  876.  
  877. # we have a <tag>
  878. set tag [string trim $cmd "<>"]
  879. Debug.form {[self] creating tag $cmd}
  880. oo::objdefine [self] method <$tag> {args} [string map [list %T% $tag] {
  881. Debug.form {[self] form tag @T ($args)}
  882. if {[llength $args]%2} {
  883. set content [lindex $args end]
  884. set args [lrange $args 0 end-1]
  885. } else {
  886. set content ""
  887. }
  888. return "<[my attr %T% [my defaults %T% {*}$args]]>$content</%T%>"
  889. }]
  890.  
  891. return [uplevel 1 [list $cmd {*}$args]]
  892. }
  893.  
  894. constructor {args} {
  895. variable Fdefaults [dict create {*}{
  896. textarea {compact 0}
  897. form {method post}
  898. fieldset {vertical 0}
  899. submit {alt Submit}
  900. reset {alt Reset}
  901. option {}
  902. }]
  903. variable metadata {} ;# remember field configs
  904. variable tabindex 0 ;# taborder for fields
  905. variable uniqID 0 ;# unique ID for fields
  906. variable scripting 1 ;# permit scripting options
  907.  
  908. if {$args ne {}} {
  909. variable {*}$args
  910. }
  911.  
  912. if {$scripting} {
  913. variable coreA {id class style title}
  914. } else {
  915. variable coreA {id class title}
  916. }
  917. variable i18nA {lang dir}
  918.  
  919. set commonOn {
  920. onclick ondblclick onmousedown onmouseup onmouseover
  921. onmousemove onmouseout onkeypress onkeydown onkeyup
  922. }
  923. if {$scripting} {
  924. variable eventA $commonOn
  925. } else {
  926. variable eventA {}
  927. }
  928.  
  929. foreach on [list {*}$commonOn onsubmit onfocus onblur onselect onchange] {
  930. if {$scripting} {
  931. set $on $on
  932. } else {
  933. set $on ""
  934. }
  935. }
  936.  
  937. variable allA [subst {
  938. $coreA
  939. $i18nA
  940. $eventA
  941. }]
  942.  
  943. variable fieldsetA $allA
  944. variable accessA [subst {accesskey $allA}]
  945. variable formA [subst {action method enctype accept-charset accept $onsubmit $allA}]
  946. variable fieldA [subst {name disabled size tabindex accesskey $onfocus $onblur value $allA}]
  947. variable textareaA [subst {name rows cols disabled readonly tabindex accesskey $onfocus $onblur $onselect $onchange $allA}]
  948. variable buttonA [subst {value checked $fieldA $onselect $onchange type}]
  949. variable boxA [subst {value checked $fieldA $onselect $onchange type}]
  950. variable textA [subst {$fieldA readonly maxlength $onselect $onchange alt type}]
  951. variable imageA [subst {src alt $fieldA $onselect $onchange type}]
  952. variable fileA [subst {$fieldA accept $onselect $onchange type}]
  953. variable selectA [subst {name size multiple disabled tabindex $onfocus $onblur $onchange $allA}]
  954. variable optgroupA [subst {disabled label $allA}]
  955. variable optionA [subst {selected disabled label value $allA}]
  956. variable legendA [subst {$allA}]
  957. variable keygenA [subst {$fieldA name challenge keytype keyparams type}]
  958. variable tags {}
  959. foreach m [info class methods FormClass -all] {
  960. if {![string match <* $m]} continue
  961. lappend tags [string trim $m <>] {}
  962. }
  963. }
  964.  
  965. set meth {}
  966. foreach m [info class methods FormClass -all -private] {
  967. if {![string match <* $m]} continue
  968. lappend meth $m
  969. interp alias {} $m {} Form $m
  970. }
  971. export {*}[info class methods FormClass -all] {*}$meth ;# ensure <form>s are visible
  972. }
  973. ::FormClass create ::Form
  974.  
  975. if {[info exists argv0] && ($argv0 eq [info script])} {
  976. Form default textarea rows 8 cols 60
  977.  
  978. if {0} {
  979. puts "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"><html><head></head><body>"
  980. puts [<form> xxx action http:moop.html {
  981. [<p> "This is a form to enter your account details"]
  982. [<fieldset> details vertical 1 title "Account Details" {
  983. [<legend> "Account Details"]
  984. [<text> user label "User name" title "Your preferred username (only letters, numbers and spaces)"]
  985. [<text> email label "Email Address" title "Your email address" moop]
  986. [<hidden> hidden moop]
  987. }]
  988. [<fieldset> passwords maxlength 16 size 16 {
  989. [<legend> "Passwords"]
  990. [<p> "Type in your preferred password, twice. Leaving it blank will generate a random password for you."]
  991. [<password> password]
  992. [<password> repeat]
  993. }]
  994. [<radioset> illness legend "Personal illnesses" {
  995. +none 0
  996. lameness 1
  997. haltness 2
  998. blindness 2
  999. }]
  1000. [<checkset> illness vertical 1 legend "Personal illnesses" {
  1001. +none 0
  1002. lameness 1
  1003. haltness 2
  1004. blindness 2
  1005. }]
  1006. [<select> selname legend "Shoe Size" title "Security dictates that we know your approximate shoe size" {
  1007. [<option> value moop1 label moop1 value 1 "Petit"]
  1008. [<option> label moop2 value moop2 value 2 "Massive"]
  1009. }]
  1010. [<fieldset> personal legend "Personal Information" {
  1011. [<text> fullname label "full name" title "Full name to be used in email."] [<text> phone label phone title "Phone number for official contact"]
  1012. }]
  1013. [<p> "When you create the account instructions will be emailed to you. Make sure your email address is correct."]
  1014. [<textarea> te compact 1 {
  1015. This is some default text to be getting on with
  1016. It's fairly cool. Note how it's left aligned.
  1017. }]
  1018. <br>[<submit> submit "Create New Account"]
  1019.  
  1020. [<br>]
  1021. [<fieldset> permissions -legend Permissions {
  1022. [<fieldset> gpermF style "float:left" title "Group Permissions." {
  1023. [<legend> Group]
  1024. [<checkbox> gperms title "Can group members read this page?" value 1 checked 1 read]
  1025. [<checkbox> gperms title "Can group members modify this page?" value 2 checked 1 modify]
  1026. [<checkbox> gperms title "Can group members add to this page?" value 4 checked 1 add]
  1027. [<br>][<text> group title "Which group owns this page?" label "Group: "]
  1028. }]
  1029. [<fieldset> opermF style "float:left" title "Default Permissions." {
  1030. [<legend> Anyone]
  1031. [<checkbox> operms title "Can anyone read this page?" value 1 checked 1 read]
  1032. [<checkbox> operms title "Can anyone modify this page?" value 2 modify]
  1033. [<checkbox> operms title "Can anyone add to this page?" value 4 add]
  1034. }]
  1035. }]
  1036. [<br>]
  1037. [<div> class buttons [subst {
  1038. [<submit> class positive {
  1039. [<img> src /images/icons/tick.png alt ""] Save
  1040. }]
  1041.  
  1042. [<a> href /password/reset/ [subst {
  1043. [<img> src /images/icons/textfield_key.png alt ""] Change Password
  1044. }]]
  1045.  
  1046. [<a> href "#" class negative [subst {
  1047. [<img> src /images/icons/cross.png alt ""] Cancel
  1048. }]]
  1049. }]]
  1050. }]
  1051. puts "<hr />"
  1052. set body {
  1053. [<fieldset> fsearch {
  1054. [<submit> submit "Search"]
  1055. [<text> kw title "Search Text"]
  1056. [<br> clear both]
  1057. [<radioset> scope {fieldset style} "float:left" legend "Search scope" {
  1058. +site 0
  1059. section 1
  1060. }]
  1061. [<select> newer {fieldset style} "float:left" legend "Newer Than" {
  1062. [<option> week value "last week"]
  1063. [<option> fortnight value "last fortnight"]
  1064. [<option> month value "last month"]
  1065. [<option> year value "last year"]
  1066. }]
  1067. [<select> older {fieldset style} "float:left" legend "Older Than" {
  1068. [<option> week value "last week"]
  1069. [<option> fortnight value "last fortnight"]
  1070. [<option> month value "last month"]
  1071. [<option> year value "last year"]
  1072. }]
  1073. [<select> sort {fieldset style} "float:left" legend "Sort By" {
  1074. [<option> title value title]
  1075. [<option> author value author]
  1076. }]
  1077. }]
  1078. [<fieldset> sr1 {
  1079. [<radioset> scope1 label "Search scope" {
  1080. +site 0
  1081. section 1
  1082. }]
  1083. [<select> newer1 label "Newer Than" {
  1084. [<option> week value "last week"]
  1085. [<option> fortnight value "last fortnight"]
  1086. [<option> month value "last month"]
  1087. [<option> year value "last year"]
  1088. }]
  1089. [<select> older1 label "Older Than" {
  1090. [<option> week value "last week"]
  1091. [<option> fortnight value "last fortnight"]
  1092. [<option> month value "last month"]
  1093. [<option> year value "last year"]
  1094. }]
  1095. [<selectset> sort1 label "Sort By" {
  1096. title
  1097. author
  1098. }]
  1099. }]
  1100. }
  1101. puts [<form> yyy action http:moop.html $body]
  1102. puts "</body>\n</html>"
  1103. }
  1104.  
  1105. if {1} {
  1106. Debug on form 10
  1107. puts "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"><html><head></head><body>"
  1108. puts [Form layout foo {
  1109. fieldset fsearch {
  1110. submit submit "Search"
  1111. text kw title "Search Text"
  1112. <br> clear both
  1113. radioset scope {fieldset style} "float:left" legend "Search scope" {
  1114. +site 0
  1115. section 1
  1116. }
  1117. select newer {fieldset style} "float:left" legend "Newer Than" {
  1118. option week value "last week"
  1119. option fortnight value "last fortnight"
  1120. option month value "last month"
  1121. option year value "last year"
  1122. }
  1123. select older {fieldset style} "float:left" legend "Older Than" {
  1124. option week value "last week"
  1125. option fortnight value "last fortnight"
  1126. option month value "last month"
  1127. option year value "last year"
  1128. }
  1129. select sort {fieldset style} "float:left" legend "Sort By" {
  1130. option title value title
  1131. option author value author
  1132. }
  1133. }
  1134. fieldset sr1 style moop {
  1135. radioset scope1 label "Search scope" {
  1136. +site 0
  1137. section 1
  1138. }
  1139. select newer1 label "Newer Than" {
  1140. option week value "last week"
  1141. option fortnight value "last fortnight"
  1142. option month value "last month"
  1143. option year value "last year"
  1144. }
  1145. select older1 label "Older Than" {
  1146. option week value "last week"
  1147. option fortnight value "last fortnight"
  1148. option month value "last month"
  1149. option year value "last year"
  1150. }
  1151. selectset sort1 label "Sort By" {
  1152. title
  1153. author
  1154. }
  1155. }
  1156. text fullname label "full name"
  1157. button foo
  1158. radioset rs ...
  1159. text text ...
  1160. }]
  1161. puts "</body>\n</html>"
  1162. }
  1163. }
  1164. # vim: ts=8:sw=4:noet