1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
4 # valid_status_changed(isvalid?, {reasons}) Fired when the form valid status
6 # onchange(datarray) Fired when some form data is changed
7 # onchange,field(newvalue) Fired when specific form element is changed
9 proc tlc::form {pathName args} {
10 return [uplevel [list tlc::Form $pathName] $args]
13 ::itk::usual tlc::Form {
14 # This is a placeholder. Flesh out with appropriate options
19 inherit tlc::Border tlc::Handlers tlc::Textvariable tlc::Signalsource
24 itk_option define -padding padding Padding 0 {need_rerender}
25 itk_option define -tooltipdelay toolTipDelay ToolTipDelay 1500 {}
26 itk_option define -tooltiptimeout toolTipTimeout ToolTipTimeout 3500 {}
27 itk_option define -winding winding Winding v {need_rerender}
31 variable state "normal"
34 method set_data {args}
36 method get_data {args}
38 method itemconfig {name args}
40 method path_by_var {varname}
41 method set_tips {args}
43 method dirty_gate_ref {} ;# Obsolete, use signal_ref form_dirty
44 method valid_gate_ref {} ;# Obsolete, use signal_ref form_valid
45 method changed_dom_ref {}
47 method mark_dirty {state}
48 method item_attach_signal {name signal {sense normal}}
49 method item_attach_expression {name expression}
50 method varname_from_path {path}
51 method arm_dirty {state}
52 method force_form_valid_update {}
53 method valid_condition {new_condition desc fields}
54 method valid_signal {signal desc fields}
55 method default_options {type args}
59 method textvariable_changed {newvalue}
60 method handlers_debug {lvl msg} {log $lvl $msg}
61 method widget_destroyed {}
72 variable valid_toggles
74 variable expression_lists
75 variable valid_conditions {}
76 variable valid_signals
80 variable default_options
83 method need_rerender {}
84 method dat_changed {n1 n2 op}
85 method clear_valid_conditions {}
87 method valid_changed {condition desc fields newstate}
88 method update_valid_desc {}
89 method enabled_changed {newstate}
90 method form_valid_reasons_changed {}
91 method canonize_type {type}
97 configbody tlc::Form::schema { #<<<1
99 set schema [tlc::decomment $schema]
104 configbody tlc::Form::state { #<<<1
105 log debug "state: ($state)"
106 [stategate_ref] configure -default [expr {$state == "normal"}]
110 configbody tlc::Form::tooltipdelay { #<<<1
111 $w.tips configure -delay $itk_option(-tooltipdelay)
115 configbody tlc::Form::tooltiptimeout { #<<<1
116 $w.tips configure -showtime $itk_option(-tooltiptimeout)
120 body tlc::Form::constructor {args} { #<<<1
122 array set paths_by_var {}
124 array set valid_toggles {}
125 array set expressions {}
126 array set expression_lists {}
127 array set valid_signals {}
128 array set field_valid {}
130 array set default_options {}
132 tlc::Domino #auto dominos(need_rerender) -name "$w need_rerender"
133 tlc::Domino #auto dominos(need_valid_desc_update) \
134 -name "$w need_valid_desc_update"
135 tlc::Varwatch #auto signals(form_dirty) -name "$w form_dirty"
136 tlc::Vardomino #auto dominos(changed) -name "$w changed" \
137 -textvariable [scope dat]
138 $signals(form_dirty) attach_dirtyvar [scope dat]
139 $signals(form_dirty) register_handler onchange_info [code $this dat_changed]
140 tlc::Hoverbox $w.tips
141 tlc::Hoverbox $w.valid_tips
142 tlc::Gate #auto signals(enabled) -name "$w enabled" \
143 -mode "and" -default 1
144 tlc::Gate #auto signals(form_valid) -name "$w form_valid" \
145 -mode "and" -default 1
146 tlc::Domino #auto dominos(reasons_changed) -name "$w reasons_changed"
148 $signals(enabled) attach_input [stategate_ref]
149 $signals(enabled) attach_output [code $this enabled_changed]
151 $dominos(reasons_changed) attach_output \
152 [code $this form_valid_reasons_changed]
153 $signals(enabled) attach_output [list $dominos(reasons_changed) tip]
155 $dominos(need_rerender) attach_output [code $this rerender]
156 $dominos(need_valid_desc_update) attach_output \
157 [code $this update_valid_desc]
159 eval itk_initialize $args
164 log debug "Setting name ($name) for $w"
169 body tlc::Form::destructor {} { #<<<1
172 # Thse reference widgets that may not exist anymore (if we are here
173 # because of destroy rather than delete object, for instance), and
174 # the standard cleanup will have them change state, and hence try to
175 # configure their widgets. Doing this causes them to die before their
176 # inputs, which stops them trying to update their outputs
178 #foreach child [winfo children $w] {
179 # if {[itcl::is object -class tlc::Form $child]} {
180 # log debug "Pre-emptively deleting subform $child"
181 # delete object $child
187 body tlc::Form::set_data {args} { #<<<1
188 if {[llength $args] == 1} {
189 set data [lindex $args 0]
193 if {[llength $data] % 2 != 0} {
194 log error "Badly formatted data, must be a list of key value pairs"
195 error "Badly formatted data, must be a list of key value pairs" "" \
196 [list data_format_error]
199 $signals(form_dirty) disarm
203 foreach {varname exprs} [array get expression_lists] {
204 foreach exprname $exprs {
205 $expressions($exprname) reassess
209 $signals(form_dirty) arm
210 if {[$signals(form_dirty) is_armed]} {
211 $signals(form_dirty) set_state 0
216 body tlc::Form::set_key {args} { #<<<1
218 switch -- [llength $args] {
219 0 {error "No key specified" "" [list syntax_error no_key_specified]}
220 1 {error "No value specified" "" [list syntax_error no_value_specified]}
222 set key [lindex $args 0]
223 set val [lindex $args 1]
224 return [set_data $key $val]
228 set key [lindex $args 0]
229 set keys [lrange $args 1 end-1]
230 set val [lindex $args end]
231 set handler [path_by_var $key]
232 if {[itcl::is object $handler] && [$handler isa tlc::Form]} {
233 eval [list $handler set_key] $keys [list $val]
234 set dat($key) [$handler get_data]
236 # TODO: recursive setter that composes the nested array list on unwind
237 error "Only subforms are currently supported for deep key sets" "" \
238 [list not_implemented]
243 body tlc::Form::get_data {args} { #<<<1
244 $dominos(need_rerender) force_if_pending
246 if {[llength $args] == 0} {
247 return [array get dat]
248 } elseif {[llength $args] == 1} {
249 set key [lindex $args 0]
250 if {![info exists dat($key)]} {
251 error "Bad key: \"$key\", should be one of [join [array names tmp] {, }]" "" \
252 [list bad_key [list $key]]
256 set last [array get dat]
264 error "Cannot build array from key level [llength $so_far] \"[join $so_far ->]\": $errmsg" "" \
265 [list format_error $so_far]
269 if {![info exists tmp($key)]} {
270 error "Bad key: \"[join $so_far ->]\", should be one of [join [array names tmp] {, }]" "" \
271 [list bad_key $so_far]
280 body tlc::Form::dirty_gate_ref {} { #<<<1
281 log warning "dirty_gate_ref deprecated, use \"signal_ref form_dirty\" instead"
282 return $signals(form_dirty)
286 body tlc::Form::rerender {} { #<<<1
287 if {$schema == $oldschema} return
291 $signals(form_dirty) disarm
292 catch {eval destroy [lindex [tlc::intersect3 [winfo children $w] [list $w.tips $w.valid_tips]] 0]}
294 # Layout context init
296 label_col_args_sticky {}
297 label_cell_args_sticky {-anchor ne}
298 label_widget_args_sticky {}
299 cell_args_sticky {-anchor nw}
302 set layout(row_args_sticky) [list -pady $itk_option(-padding)]
304 catch {unset paths}; array set paths {}
305 catch {unset paths_by_var}; array set paths_by_var {}
306 catch {unset toggles}; array set toggles {}
307 catch {unset valid_toggles}; array set valid_toggles {}
308 catch {unset field_valid}; array set field_valid {}
309 catch {unset valid_signals}; array set valid_signals {}
310 catch {unset expressions}
311 catch {unset expression_lists}
312 clear_valid_conditions
317 foreach {label info} $schema {
323 set layout(label_cell_args) $layout(label_cell_args_sticky)
324 set layout(label_col_args) $layout(label_col_args_sticky)
325 set layout(label_widget_args) $layout(label_widget_args_sticky)
326 set layout(cell_args) $layout(cell_args_sticky)
327 set layout(row_args) $layout(row_args_sticky)
328 set layout(col_args) $layout(col_args_sticky)
331 if {[string index $label 0] == "_"} {
334 if {$label == "_layout"} {
335 switch -- [lindex $info 0] {
339 label_cell_args_sticky -
340 label_widget_args_sticky -
341 label_col_args_sticky {
342 set layout([lindex $info 0]) [lrange $info 1 end]
343 set layout([string range [lindex $info 0] 0 end-7]) \
347 log warning "_layout label_args_sticky is deprecated - use label_cell_args_sticky"
348 set layout(label_cell_args_sticky) [lrange $info 1 end]
349 set layout(label_cell_args) \
359 set layout([lindex $info 0]) [lrange $info 1 end]
363 log warning "_layout label_args is deprecated - use label_cell_args"
364 set layout(label_cell_args) [lrange $info 1 end]
371 switch -- [string index $itk_option(-winding) 0] {
375 set layout(row_args) $layout(row_args_sticky)
382 set layout(col_args) $layout(col_args_sticky)
393 switch -- [string index $itk_option(-winding) 0] {
395 set amnt [lindex $info 1]
396 if {$amnt == ""} {set amnt 1}
403 set amnt [lindex $info 1]
404 if {$amnt == ""} {set amnt 1}
411 log warning "default_options mode of _layout is deprecated. Use top level directive _default_options instead"
412 set type [canonize_type [lindex $info 1]]
413 set default_options($type) [lrange $info 2 end]
417 error "Unrecognised layout parameter: ([lindex $info 0])"
423 _validation - _validation_not_blank { #<<<
424 if {$label == "_validation"} {
425 valid_condition [lindex $info 0] [lindex $info 1] [lindex $info 2]
427 if {$label == "_validation_not_blank"} {
428 set template [lindex $info 0]
429 foreach {labelname varname} [lrange $info 1 end] {
430 set condition "\[string trim \$dat([string map {{ } {\ } {)} {\)}} $varname])\] != {}"
433 [string map [list %1 $labelname] $template] \
439 _tips - _tooltips { #<<<
447 _default_options { #<<<
448 set type [canonize_type [lindex $info 0]]
449 set default_options($type) [lrange $info 1 end]
453 error "Invalid meta directive \"$label\", must be one of _layout, _validation, _validation_not_blank, _tips or _tooltips" "" [list invalid_meta_directive $label]
462 foreach {varname type} $info break
463 lappend formvars $varname
464 set type [canonize_type $type]
466 if {[info exists default_options($type)]} {
467 set arglist [concat $default_options($type) [lrange $info 2 end]]
469 set arglist [lrange $info 2 end]
472 if {[string index $label 0] == " "} {
473 label $w.$row,$col,l -text "" -width 0 -highlightthickness 0 \
474 -background $itk_option(-background)
476 label $w.$row,$col,l -text $label \
477 -background $itk_option(-background)
479 if {[llength $layout(label_widget_args)] > 0} {
480 eval [list $w.$row,$col,l configure] $layout(label_widget_args)
483 if {![info exists dat($varname)]} {
486 if {[string first " " $varname] != -1} {
487 # Itcl bug (still as of 3.3) prevents scope / resolver working
488 # with arrays whose keys contain spaces. We craft our own here
489 # that works with the resolver
492 #set scoped_varname "[list @itcl $this] [namespace current]::dat($varname)"
493 set tmp [scope dat($varname)]
494 set scoped_varname [concat [lrange $tmp 0 1] [lindex $tmp 2]]
496 set scoped_varname [scope dat($varname)]
499 tlc::Gate #auto field_valid($varname) -name "$w field_valid $varname" \
500 -mode "and" -default 1
501 tlc::StateToggle #auto valid_toggles($varname) \
502 -mode "or" -default 1 \
504 -foreground {red black}
505 $valid_toggles($varname) attach_signal $signals(enabled) inverted
506 $valid_toggles($varname) attach_signal $field_valid($varname)
508 $valid_toggles($varname) attach_output \
509 [list $dominos(reasons_changed) tip]
511 set toggle {-state {disabled normal}}
514 entry $w.$row,$col,v -textvariable $scoped_varname
518 checkbutton $w.$row,$col,v -variable $scoped_varname
522 label $w.$row,$col,v -textvariable $scoped_varname \
524 -font [$tlc::theme setting boldfont]
528 tlc::vartextbox $w.$row,$col,v -textvariable $scoped_varname
532 button $w.$row,$col,v
536 tlc::mycombobox $w.$row,$col,v -textvariable $scoped_varname
540 tlc::Dateentry $w.$row,$col,v -textvariable $scoped_varname
544 tlc::Calendar $w.$row,$col,v -command [code set dat($varname)]
548 tlc::Fileselectbox $w.$row,$col,v -textvariable $scoped_varname
552 tlc::Browse_treeview_list $w.$row,$col,v \
553 -textvariable $scoped_varname \
554 -width 300 -height 110
558 tlc::Lookup $w.$row,$col,v -textvariable $scoped_varname
562 tlc::Spinint $w.$row,$col,v -textvariable $scoped_varname
566 tlc::Spinner $w.$row,$col,v -textvariable $scoped_varname
567 # TODO: wire valid_signal?
571 message $w.$row,$col,v \
572 -textvariable $scoped_varname \
573 -font [$tlc::theme setting boldfont]
578 entry $w.$row,$col,v -textvariable $scoped_varname \
580 -validatecommand {string is integer {%P}}
584 Tagentry $w.$row,$col,v -textvariable $scoped_varname
588 tlc::Radiogroup $w.$row,$col,v -textvariable $scoped_varname
592 tlc::Checkgroup $w.$row,$col,v -textvariable $scoped_varname
596 tlc::Form $w.$row,$col,v -textvariable $scoped_varname \
597 -name "$name -> $varname"
598 valid_signal [$w.$row,$col,v signal_ref form_valid] "" $varname
602 tlc::Tablelist $w.$row,$col,v -textvariable $scoped_varname
603 # TODO: wire valid_signal?
607 if {[info exists tlc::Form::custom_types($type)]} {
608 $tlc::Form::custom_types($type) $w.$row,$col,v \
609 -textvariable $scoped_varname
611 log error "Unknown type: ($type)"
616 set paths($label) $w.$row,$col,v
617 set paths_by_var($varname) $w.$row,$col,v
618 eval [list tlc::StateToggle #auto toggles($varname) $w.$row,$col,v] \
620 $toggles($varname) attach_signal $signals(enabled)
622 if {[llength $arglist] != 0} {
623 eval [list $w.$row,$col,v configure] $arglist
626 set dc [expr {$col+1}]
627 eval [list blt::table $w $w.$row,$col,l $row,$col] \
628 $layout(label_cell_args)
629 blt::table configure $w c$col -resize none
630 eval [list blt::table $w $w.$row,$col,v $row,$dc] $layout(cell_args)
631 eval [list blt::table configure $w c$col] $layout(label_col_args)
632 eval [list blt::table configure $w c$dc] $layout(col_args)
633 eval [list blt::table configure $w r$row] $layout(row_args)
635 switch -- [string index $itk_option(-winding) 0] {
650 if {![info exists signals(form_dirty)]} {
651 log error "Freak out - signals(form_dirty) missing\n$w\n[tlc::stackdump]"
654 $signals(form_dirty) arm
655 $signals(form_dirty) set_state 0
659 body tlc::Form::takefocus {} { #<<<1
660 $dominos(need_rerender) force_if_pending
665 body tlc::Form::need_rerender {} { #<<<1
666 $dominos(need_rerender) tip
670 body tlc::Form::itemconfig {name args} { #<<<1
671 set path [path $name]
672 eval [list $path configure] $args
676 body tlc::Form::path {name} { #<<<1
677 $dominos(need_rerender) force_if_pending
679 if {[string is integer -strict $name]} {
680 if {[winfo exists $w.$name,0,v]} {
683 error "No such item index: ($name)"
685 } elseif {[regexp {[0-9]+,[0-9]+} $name]} {
686 foreach {r c} [split $name ,] break
687 if {[winfo exists $w.$r,$c,v]} {
690 error "No such item index: ($name)"
693 if {![info exists paths($name)]} {
694 error "No such form item: ($name), choose from (\"[join [array names paths] {", "}]\")"
701 body tlc::Form::changed_dom_ref {} { #<<<1
702 return $dominos(changed)
706 body tlc::Form::set_tips {args} { #<<<1
707 if {[llength $args] == 1} {
708 # Support the variant syntax of one item packed with all the tips
710 set args [lindex $args 0]
712 foreach {label tip} $args {
713 set widget [path $label]
714 $w.tips attach $widget $tip
720 body tlc::Form::mark_dirty {state} { #<<<1
722 $signals(form_dirty) set_state $state
726 body tlc::Form::path_by_var {varname} { #<<<1
727 $dominos(need_rerender) force_if_pending
729 if {![info exists paths_by_var($varname)]} {
730 error "No such form item: ($varname)" "" \
731 [list invalid_form_item $varname]
733 return $paths_by_var($varname)
736 body tlc::Form::dat_changed {n1 n2 op} { #<<<1
738 log debug "dat($n2) changed: ($dat($n2))"
739 } elseif {$op == "u"} {
740 log debug "dat($n2) unset"
742 set_textvariable [get_data]
744 if {[$signals(form_dirty) is_armed]} {
746 if {[info exists dat($n2)]} {
747 if {[info exists expression_lists($n2)]} {
748 foreach exprname $expression_lists($n2) {
749 $expressions($exprname) reassess
752 invoke_handlers onchange,$n2 $dat($n2)
754 invoke_handlers onchange [array get dat]
756 $signals(form_dirty) set_state 1
761 body tlc::Form::clear_data {} { #<<<1
763 $signals(form_dirty) disarm
766 # TODO: figure out why this is necessary
767 foreach key [array names dat] {
772 #array set toggles {}
773 #array unset expressions
774 $signals(form_dirty) set_state 0
775 $signals(form_dirty) arm
779 body tlc::Form::item_attach_signal {name signal {sense normal}} { #<<<1
780 set path [path $name]
781 set varname [varname_from_path $path]
782 $toggles($varname) attach_signal $signal $sense
786 body tlc::Form::item_attach_expression {name expression} { #<<<1
787 set path [path $name]
788 set varname [varname_from_path $path]
789 #array unset expressions $varname
790 set exprname "$varname[incr expr_seq]"
791 tlc::Expression #auto expressions($exprname) -name "Form expression on $varname ($exprname)"
792 lappend expression_lists($varname) $exprname
793 set expression [string map [list \$value %<dat($varname)%>] $expression]
794 $expressions($exprname) set_expression $expression
796 return $expressions($exprname)
800 body tlc::Form::varname_from_path {path} { #<<<1
802 foreach {v p} [array get paths_by_var] {
813 error "No varname known for path: ($path)"
818 body tlc::Form::arm_dirty {state} { #<<<1
821 $signals(form_dirty) arm
823 $signals(form_dirty) disarm
828 body tlc::Form::valid_gate_ref {} { #<<<1
829 log warning "valid_gate_ref deprecated, use \"signal_ref form_valid\" instead"
830 return $signals(form_valid)
834 body tlc::Form::valid_condition {new_condition desc fields} { #<<<1
835 tlc::Signal #auto valid_signals($new_condition) -name "valid_signals($new_condition)"
836 lappend valid_conditions [list $new_condition $desc $fields $valid_signals($new_condition)]
838 foreach field $fields {
839 $field_valid($field) attach_input $valid_signals($new_condition)
840 $valid_toggles($field) attach_output \
841 [code $this valid_changed $new_condition $desc $fields]
846 $signals(form_valid) attach_input $valid_signals($new_condition)
850 body tlc::Form::valid_signal {signal desc fields} { #<<<1
851 $dominos(need_rerender) force_if_pending
853 lappend valid_conditions [list {} $desc $fields $signal]
855 foreach field $fields {
856 $field_valid($field) attach_input $signal
857 $valid_toggles($field) attach_output \
858 [code $this valid_changed {} $desc $fields]
861 $signals(form_valid) attach_input $signal
865 body tlc::Form::check_valid {} { #<<<1
866 foreach condition_desc $valid_conditions {
867 foreach {condition desc fields signal} $condition_desc break
868 if {$condition != {}} {
869 $signal set_state [expr $condition]
875 body tlc::Form::clear_valid_conditions {} { #<<<1
876 set valid_conditions {}
882 body tlc::Form::valid_changed {condition desc fields newstate} { #<<<1
883 $dominos(need_valid_desc_update) tip
887 body tlc::Form::update_valid_desc {} { #<<<1
888 array set new_desc {}
890 foreach condition_desc $valid_conditions {
891 foreach {condition desc fields signal} $condition_desc break
892 foreach field $fields {
893 if {![$valid_toggles($field) state]} {
894 lappend new_desc($field) $desc
899 set obsolete [lindex [tlc::intersect3 [array names paths_by_var] [array names new_desc]] 0]
900 foreach field $obsolete {
901 $w.valid_tips detach [$valid_toggles($field) target]
903 foreach {field desclist} [array get new_desc] {
904 $w.valid_tips attach [$valid_toggles($field) target] [join $desclist \n]
909 body tlc::Form::force_form_valid_update {} { #<<<1
910 form_valid_reasons_changed
914 body tlc::Form::enabled_changed {newstate} { #<<<1
916 $w.valid_tips popdown
921 body tlc::Form::form_valid_reasons_changed {} { #<<<1
922 set newstate [$signals(form_valid) state]
924 invoke_handlers valid_status_changed $newstate {}
926 if {[$signals(enabled) state]} {
928 foreach condition_desc $valid_conditions {
929 foreach {condition desc fields signal} $condition_desc break
930 if {![$signal state]} {
931 lappend reasons $desc
934 invoke_handlers valid_status_changed $newstate $reasons
936 invoke_handlers valid_status_changed $newstate "Form disabled"
942 body tlc::Form::textvariable_changed {newvalue} { #<<<1
943 log debug "$name newvalue: ($newvalue)"
944 array set tmp $newvalue
945 set existing [array names dat]
946 set new [array names tmp]
949 set removed_keys [lindex [tlc::intersect3 $existing $new] 2]
950 foreach key $removed_keys {
958 body tlc::Form::default_options {type args} { #<<<1
959 set type [canonize_type $type]
961 set default_options($type) $args
965 body tlc::Form::canonize_type {type} { #<<<1
968 entry {return "entry"}
970 checkbutton {return "checkbutton"}
971 label {return "label"}
975 button {return "button"}
977 mycombobox {return "combobox"}
979 dateentry {return "dateentry"}
980 calendar {return "calendar"}
981 fileselect {return "fileselect"}
983 lookup {return "lookup"}
984 spinint {return "spinint"}
985 spinner {return "spinner"}
986 message {return "message"}
987 intentry {return "intentry"}
988 tagentry {return "tagentry"}
989 radiogroup {return "radiogroup"}
990 checkgroup {return "checkgroup"}
992 form {return "subform"}
993 tablelist {return "tablelist"}
996 if {[info exists tlc::Form::custom_types($type)]} {
999 error "Unknown type: ($type)"
1006 body tlc::Form::cleanup {} { #<<<1
1007 #log warning "$w:[tlc::stackdump]"
1009 array unset valid_toggles
1015 body tlc::Form::widget_destroyed {} { #<<<1
1018 #log warning "$w done"