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
20 #inherit tlc::Formbase tlc::Border
25 itk_option define -padding padding Padding 0 {need_rerender}
26 itk_option define -tooltipdelay toolTipDelay ToolTipDelay 1500 {}
27 itk_option define -tooltiptimeout toolTipTimeout ToolTipTimeout 3500 {}
28 itk_option define -winding winding Winding v {need_rerender}
32 variable state "normal"
35 method set_data {args}
37 method get_data {args}
39 method itemconfig {name args}
41 method path_by_var {varname}
42 method set_tips {args}
44 method dirty_gate_ref {} ;# Obsolete, use signal_ref form_dirty
45 method valid_gate_ref {} ;# Obsolete, use signal_ref form_valid
46 method changed_dom_ref {}
48 method mark_dirty {state}
49 method item_attach_signal {name signal {sense normal}}
50 method item_attach_expression {name expression}
51 method varname_from_path {path}
52 method arm_dirty {state}
53 method force_form_valid_update {}
54 method valid_condition {new_condition desc fields}
55 method valid_signal {signal desc fields}
56 method default_options {type args}
60 method textvariable_changed {newvalue}
61 method handlers_debug {lvl msg} {log $lvl $msg}
62 method widget_destroyed {}
73 variable valid_toggles
75 variable expression_lists
76 variable valid_conditions {}
77 variable valid_signals
81 variable default_options
82 variable onchange_handlers {}
86 method need_rerender {}
87 method dat_changed {n1 n2 op}
88 method clear_valid_conditions {}
90 method valid_changed {condition desc fields newstate}
91 method update_valid_desc {}
92 method enabled_changed {newstate}
93 method form_valid_reasons_changed {}
94 method canonize_type {type}
96 method run_onchange_handlers {}
101 configbody tlc::Form::schema { #<<<1
103 set schema [tlc::decomment $schema]
108 configbody tlc::Form::state { #<<<1
109 log debug "state: ($state)"
110 [stategate_ref] configure -default [expr {$state eq "normal"}]
114 configbody tlc::Form::tooltipdelay { #<<<1
115 $w.tips configure -delay $itk_option(-tooltipdelay)
119 configbody tlc::Form::tooltiptimeout { #<<<1
120 $w.tips configure -showtime $itk_option(-tooltiptimeout)
124 body tlc::Form::constructor {args} { #<<<1
126 array set paths_by_var {}
128 array set valid_toggles {}
129 array set expressions {}
130 array set expression_lists {}
131 array set valid_signals {}
132 array set field_valid {}
134 array set default_options {}
136 tlc::Domino #auto dominos(need_rerender) -name "$w need_rerender"
137 tlc::Domino #auto dominos(run_onchange_handlers) -name "$w run_onchange_handlers"
138 tlc::Domino #auto dominos(need_valid_desc_update) \
139 -name "$w need_valid_desc_update"
140 tlc::Varwatch #auto signals(form_dirty) -name "$w form_dirty"
141 tlc::Vardomino #auto dominos(changed) -name "$w changed" \
142 -textvariable [scope dat]
143 $signals(form_dirty) attach_dirtyvar [scope dat]
144 $signals(form_dirty) register_handler onchange_info [code $this dat_changed]
145 tlc::Hoverbox $w.tips
146 tlc::Hoverbox $w.valid_tips
147 tlc::Gate #auto signals(enabled) -name "$w enabled" \
148 -mode "and" -default 1
149 tlc::Gate #auto signals(form_valid) -name "$w form_valid" \
150 -mode "and" -default 1
151 tlc::Domino #auto dominos(reasons_changed) -name "$w reasons_changed"
153 $signals(enabled) attach_input [stategate_ref]
154 $signals(enabled) attach_output [code $this enabled_changed]
156 $dominos(reasons_changed) attach_output \
157 [code $this form_valid_reasons_changed]
158 $signals(enabled) attach_output [list $dominos(reasons_changed) tip]
160 $dominos(need_rerender) attach_output [code $this rerender]
161 $dominos(need_valid_desc_update) attach_output \
162 [code $this update_valid_desc]
164 $dominos(run_onchange_handlers) attach_output \
165 [code $this run_onchange_handlers]
167 itk_initialize {*}$args
172 log debug "Setting name ($name) for $w"
174 set baselog_instancename $name
179 body tlc::Form::destructor {} { #<<<1
182 # Thse reference widgets that may not exist anymore (if we are here
183 # because of destroy rather than delete object, for instance), and
184 # the standard cleanup will have them change state, and hence try to
185 # configure their widgets. Doing this causes them to die before their
186 # inputs, which stops them trying to update their outputs
188 #foreach child [winfo children $w] {
189 # if {[itcl::is object -class tlc::Form $child]} {
190 # log debug "Pre-emptively deleting subform $child"
191 # delete object $child
197 body tlc::Form::set_data {args} { #<<<1
198 $dominos(need_rerender) force_if_pending
200 if {[llength $args] == 1} {
201 set data [lindex $args 0]
205 if {[llength $data] % 2 != 0} {
206 log error "Badly formatted data, must be a list of key value pairs"
207 error "Badly formatted data, must be a list of key value pairs" "" \
208 [list data_format_error]
211 $signals(form_dirty) disarm
213 log debug "Setting dat:"
217 foreach {varname exprs} [array get expression_lists] {
218 foreach exprname $exprs {
219 $expressions($exprname) reassess
223 $signals(form_dirty) arm
224 if {[$signals(form_dirty) is_armed]} {
225 $signals(form_dirty) set_state 0
230 body tlc::Form::set_key {args} { #<<<1
232 switch -- [llength $args] {
233 0 {error "No key specified" "" [list syntax_error no_key_specified]}
234 1 {error "No value specified" "" [list syntax_error no_value_specified]}
236 set key [lindex $args 0]
237 set val [lindex $args 1]
238 return [set_data $key $val]
242 set key [lindex $args 0]
243 set keys [lrange $args 1 end-1]
244 set val [lindex $args end]
245 set handler [path_by_var $key]
246 if {[itcl::is object $handler] && [$handler isa tlc::Form]} {
247 $handler set_key {*}$keys $val
248 set dat($key) [$handler get_data]
250 # TODO: recursive setter that composes the nested array list on unwind
251 error "Only subforms are currently supported for deep key sets" "" \
252 [list not_implemented]
257 body tlc::Form::get_data {args} { #<<<1
258 $dominos(need_rerender) force_if_pending
261 if {[llength $args] == 0} {
262 return [array get dat]
263 } elseif {[llength $args] == 1} {
264 set key [lindex $args 0]
265 if {![info exists dat($key)]} {
266 error "Bad key: \"$key\", should be one of [join [array names tmp] {, }]" "" \
267 [list bad_key [list $key]]
271 set last [array get dat]
279 error "Cannot build array from key level [llength $so_far] \"[join $so_far ->]\": $errmsg" "" \
280 [list format_error $so_far]
284 if {![info exists tmp($key)]} {
285 error "Bad key: \"[join $so_far ->]\", should be one of [join [array names tmp] {, }]" "" \
286 [list bad_key $so_far]
295 body tlc::Form::dirty_gate_ref {} { #<<<1
296 log warning "dirty_gate_ref deprecated, use \"signal_ref form_dirty\" instead"
297 return $signals(form_dirty)
301 body tlc::Form::rerender {} { #<<<1
302 if {$schema eq $oldschema} return
306 $signals(form_dirty) disarm
308 destroy {*}[lindex [tlc::intersect3 [winfo children $w] [list $w.tips $w.valid_tips]] 0]
311 # Layout context init
313 label_col_args_sticky {}
314 label_cell_args_sticky {-anchor ne}
315 label_widget_args_sticky {}
316 cell_args_sticky {-anchor nw}
319 set layout(row_args_sticky) [list -pady $itk_option(-padding)]
321 catch {unset paths}; array set paths {}
322 catch {unset paths_by_var}; array set paths_by_var {}
323 catch {unset toggles}; array set toggles {}
324 catch {unset valid_toggles}; array set valid_toggles {}
325 catch {unset field_valid}; array set field_valid {}
326 catch {unset valid_signals}; array set valid_signals {}
327 catch {unset expressions}
328 catch {unset expression_lists}
329 clear_valid_conditions
334 foreach {label info} $schema {
340 set layout(label_cell_args) $layout(label_cell_args_sticky)
341 set layout(label_col_args) $layout(label_col_args_sticky)
342 set layout(label_widget_args) $layout(label_widget_args_sticky)
343 set layout(cell_args) $layout(cell_args_sticky)
344 set layout(row_args) $layout(row_args_sticky)
345 set layout(col_args) $layout(col_args_sticky)
348 if {[string index $label 0] eq "_"} {
351 if {$label eq "_layout"} {
352 switch -- [lindex $info 0] {
356 label_cell_args_sticky -
357 label_widget_args_sticky -
358 label_col_args_sticky {
359 set layout([lindex $info 0]) [lrange $info 1 end]
360 set layout([string range [lindex $info 0] 0 end-7]) \
364 log warning "_layout label_args_sticky is deprecated - use label_cell_args_sticky"
365 set layout(label_cell_args_sticky) [lrange $info 1 end]
366 set layout(label_cell_args) \
376 set layout([lindex $info 0]) [lrange $info 1 end]
380 log warning "_layout label_args is deprecated - use label_cell_args"
381 set layout(label_cell_args) [lrange $info 1 end]
388 switch -- [string index $itk_option(-winding) 0] {
392 set layout(row_args) $layout(row_args_sticky)
399 set layout(col_args) $layout(col_args_sticky)
410 switch -- [string index $itk_option(-winding) 0] {
412 set amnt [lindex $info 1]
413 if {$amnt eq ""} {set amnt 1}
420 set amnt [lindex $info 1]
421 if {$amnt eq ""} {set amnt 1}
428 log warning "default_options mode of _layout is deprecated. Use top level directive _default_options instead"
429 set type [canonize_type [lindex $info 1]]
430 set default_options($type) [lrange $info 2 end]
434 error "Unrecognised layout parameter: ([lindex $info 0])"
440 _validation - _validation_not_blank { #<<<
441 if {$label eq "_validation"} {
442 valid_condition [lindex $info 0] [lindex $info 1] [lindex $info 2]
444 if {$label eq "_validation_not_blank"} {
445 set template [lindex $info 0]
446 foreach {labelname varname} [lrange $info 1 end] {
447 set condition "\[string trim \$dat([string map {{ } {\ } {)} {\)}} $varname])\] ne {}"
450 [string map [list %1 $labelname] $template] \
456 _tips - _tooltips { #<<<
461 log debug "Setting defaults: ($info)"
466 _default_options { #<<<
467 set type [canonize_type [lindex $info 0]]
468 set default_options($type) [lrange $info 1 end]
472 lappend onchange_handlers $info
476 error "Invalid meta directive \"$label\", must be one of _layout, _validation, _validation_not_blank, _tips or _tooltips" "" [list invalid_meta_directive $label]
485 lassign $info varname type
486 lappend formvars $varname
487 set type [canonize_type $type]
489 if {[info exists default_options($type)]} {
490 set arglist [concat $default_options($type) [lrange $info 2 end]]
492 set arglist [lrange $info 2 end]
495 if {[string index $label 0] eq " "} {
496 ttk::label $w.$row,$col,l -text "" -width 0
498 ttk::label $w.$row,$col,l -text $label
500 if {[llength $layout(label_widget_args)] > 0} {
501 $w.$row,$col,l configure {*}$layout(label_widget_args)
504 if {![info exists dat($varname)]} {
507 if {[string first " " $varname] != -1} {
508 # Itcl bug (still as of 3.3) prevents scope / resolver working
509 # with arrays whose keys contain spaces. We craft our own here
510 # that works with the resolver
513 #set scoped_varname "[list @itcl $this] [namespace current]::dat($varname)"
514 set tmp [scope dat($varname)]
515 set scoped_varname [concat [lrange $tmp 0 1] [lindex $tmp 2]]
517 set scoped_varname [scope dat($varname)]
520 tlc::Gate #auto field_valid($varname) -name "$w field_valid $varname" \
521 -mode "and" -default 1
522 tlc::StateToggle #auto valid_toggles($varname) \
523 -mode "or" -default 1 \
525 -foreground {red black}
526 #tlc::StateToggle #auto valid_toggles($varname) \
527 # -mode "or" -default 1 \
529 ## -font [list [$tlc::theme setting boldfont] [$tlc::theme setting font]]
530 $valid_toggles($varname) attach_signal $signals(enabled) inverted
531 $valid_toggles($varname) attach_signal $field_valid($varname)
532 $valid_toggles($varname) attach_output [list apply {
534 if {![winfo exists $widget]} return
536 $widget state !invalid
538 $widget state invalid
543 $valid_toggles($varname) attach_output \
544 [list $dominos(reasons_changed) tip]
546 set toggle {-state {disabled normal}}
549 ttk::entry $w.$row,$col,v -textvariable $scoped_varname \
554 ttk::checkbutton $w.$row,$col,v -variable $scoped_varname \
559 ttk::label $w.$row,$col,v -textvariable $scoped_varname \
561 -font [$tlc::theme setting boldfont] \
566 tlc::vartextbox $w.$row,$col,v -textvariable $scoped_varname \
571 ttk::button $w.$row,$col,v {*}$arglist
575 tlc::mycombobox $w.$row,$col,v -textvariable $scoped_varname \
580 tlc::Dateentry $w.$row,$col,v -textvariable $scoped_varname \
585 tlc::Calendar $w.$row,$col,v -command [code set dat($varname)] \
590 tlc::Fileselectbox $w.$row,$col,v \
591 -textvariable $scoped_varname \
596 tlc::Browse_tktreectrl_list $w.$row,$col,v \
597 -textvariable $scoped_varname \
602 tlc::Lookup $w.$row,$col,v \
603 -textvariable $scoped_varname \
608 tlc::Spinint $w.$row,$col,v \
609 -textvariable $scoped_varname \
614 tlc::Spinner $w.$row,$col,v \
615 -textvariable $scoped_varname \
617 # TODO: wire valid_signal?
621 message $w.$row,$col,v \
622 -textvariable $scoped_varname \
623 -font [$tlc::theme setting boldfont] \
629 ttk::entry $w.$row,$col,v -textvariable $scoped_varname \
631 -validatecommand {string is integer {%P}} \
636 Tagentry $w.$row,$col,v \
637 -textvariable $scoped_varname \
642 tlc::Radiogroup $w.$row,$col,v \
643 -textvariable $scoped_varname \
648 tlc::Checkgroup $w.$row,$col,v \
649 -textvariable $scoped_varname \
654 tlc::Form $w.$row,$col,v -textvariable $scoped_varname \
655 -name "$name -> $varname" \
657 valid_signal [$w.$row,$col,v signal_ref form_valid] "" $varname
661 tlc::Tablelist $w.$row,$col,v \
662 -textvariable $scoped_varname \
664 # TODO: wire valid_signal?
668 if {[info exists tlc::Form::custom_types($type)]} {
669 $tlc::Form::custom_types($type) $w.$row,$col,v \
670 -textvariable $scoped_varname \
673 log error "Unknown type: ($type)"
678 set paths($label) $w.$row,$col,v
679 set paths_by_var($varname) $w.$row,$col,v
680 tlc::StateToggle #auto toggles($varname) $w.$row,$col,v \
682 $toggles($varname) attach_signal $signals(enabled)
684 set dc [expr {$col+1}]
685 blt::table $w $w.$row,$col,l $row,$col {*}$layout(label_cell_args)
686 blt::table configure $w c$col -resize none
688 blt::table $w $w.$row,$col,v $row,$dc {*}$layout(cell_args)
689 blt::table configure $w c$col {*}$layout(label_col_args)
690 blt::table configure $w c$dc {*}$layout(col_args)
691 blt::table configure $w r$row {*}$layout(row_args)
693 switch -- [string index $itk_option(-winding) 0] {
708 if {![info exists signals(form_dirty)]} {
709 log error "Freak out - signals(form_dirty) missing\n$w\n[tlc::stackdump]"
712 run_onchange_handlers
714 $signals(form_dirty) arm
715 $signals(form_dirty) set_state 0
719 body tlc::Form::takefocus {} { #<<<1
720 $dominos(need_rerender) force_if_pending
721 if {[winfo exists $w.0,0,v]} {
727 body tlc::Form::need_rerender {} { #<<<1
728 $dominos(need_rerender) tip
732 body tlc::Form::itemconfig {name args} { #<<<1
733 set path [path $name]
734 $path configure {*}$args
738 body tlc::Form::path {name} { #<<<1
739 $dominos(need_rerender) force_if_pending
741 if {[string is integer -strict $name]} {
742 if {[winfo exists $w.$name,0,v]} {
745 error "No such item index: ($name)"
747 } elseif {[regexp {[0-9]+,[0-9]+} $name]} {
748 lassign [split $name ,] r c
749 if {[winfo exists $w.$r,$c,v]} {
752 error "No such item index: ($name)"
755 if {![info exists paths($name)]} {
756 error "No such form item: ($name), choose from (\"[join [array names paths] {", "}]\")"
763 body tlc::Form::changed_dom_ref {} { #<<<1
764 return $dominos(changed)
768 body tlc::Form::set_tips {args} { #<<<1
769 if {[llength $args] == 1} {
770 # Support the variant syntax of one item packed with all the tips
772 set args [lindex $args 0]
774 foreach {label tip} $args {
775 set widget [path $label]
776 $w.tips attach $widget $tip
782 body tlc::Form::mark_dirty {state} { #<<<1
784 $signals(form_dirty) set_state $state
788 body tlc::Form::path_by_var {varname} { #<<<1
789 $dominos(need_rerender) force_if_pending
791 if {![info exists paths_by_var($varname)]} {
792 error "No such form item: ($varname)" "" \
793 [list invalid_form_item $varname]
795 return $paths_by_var($varname)
798 body tlc::Form::dat_changed {n1 n2 op} { #<<<1
800 log debug "dat($n2) changed: ($dat($n2))"
801 } elseif {$op eq "u"} {
802 log debug "dat($n2) unset"
804 set_textvariable [get_data]
806 if {[$signals(form_dirty) is_armed]} {
808 if {[info exists dat($n2)]} {
809 if {[info exists expression_lists($n2)]} {
810 foreach exprname $expression_lists($n2) {
811 $expressions($exprname) reassess
814 invoke_handlers onchange,$n2 $dat($n2)
816 invoke_handlers onchange [array get dat]
817 $dominos(run_onchange_handlers) tip
819 $signals(form_dirty) set_state 1
824 body tlc::Form::clear_data {} { #<<<1
826 $signals(form_dirty) disarm
829 # TODO: figure out why this is necessary
830 foreach key [array names dat] {
835 #array set toggles {}
836 #array unset expressions
837 $signals(form_dirty) set_state 0
838 $signals(form_dirty) arm
842 body tlc::Form::item_attach_signal {name signal {sense normal}} { #<<<1
843 set path [path $name]
844 set varname [varname_from_path $path]
845 $toggles($varname) attach_signal $signal $sense
849 body tlc::Form::item_attach_expression {name expression} { #<<<1
850 set path [path $name]
851 set varname [varname_from_path $path]
852 #array unset expressions $varname
853 set exprname "$varname[incr expr_seq]"
854 tlc::Expression #auto expressions($exprname) -name "Form expression on $varname ($exprname)"
855 lappend expression_lists($varname) $exprname
856 set expression [string map [list \$value %<dat($varname)%>] $expression]
857 $expressions($exprname) set_expression $expression
859 return $expressions($exprname)
863 body tlc::Form::varname_from_path {path} { #<<<1
865 foreach {v p} [array get paths_by_var] {
876 error "No varname known for path: ($path)"
881 body tlc::Form::arm_dirty {state} { #<<<1
884 $signals(form_dirty) arm
886 $signals(form_dirty) disarm
891 body tlc::Form::valid_gate_ref {} { #<<<1
892 log warning "valid_gate_ref deprecated, use \"signal_ref form_valid\" instead"
893 return $signals(form_valid)
897 body tlc::Form::valid_condition {new_condition desc fields} { #<<<1
898 tlc::Signal #auto valid_signals($new_condition) -name "valid_signals($new_condition)"
899 lappend valid_conditions [list $new_condition $desc $fields $valid_signals($new_condition)]
901 foreach field $fields {
902 $field_valid($field) attach_input $valid_signals($new_condition)
903 $valid_toggles($field) attach_output \
904 [code $this valid_changed $new_condition $desc $fields]
909 $signals(form_valid) attach_input $valid_signals($new_condition)
913 body tlc::Form::valid_signal {signal desc fields} { #<<<1
914 $dominos(need_rerender) force_if_pending
916 lappend valid_conditions [list {} $desc $fields $signal]
918 foreach field $fields {
919 $field_valid($field) attach_input $signal
920 $valid_toggles($field) attach_output \
921 [code $this valid_changed {} $desc $fields]
924 $signals(form_valid) attach_input $signal
928 body tlc::Form::check_valid {} { #<<<1
929 foreach condition_desc $valid_conditions {
930 lassign $condition_desc condition desc fields signal
931 if {$condition ne {}} {
932 $signal set_state [expr $condition]
938 body tlc::Form::clear_valid_conditions {} { #<<<1
939 set valid_conditions {}
945 body tlc::Form::valid_changed {condition desc fields newstate} { #<<<1
946 $dominos(need_valid_desc_update) tip
950 body tlc::Form::update_valid_desc {} { #<<<1
951 array set new_desc {}
953 foreach condition_desc $valid_conditions {
954 lassign $condition_desc condition desc fields signal
955 foreach field $fields {
956 if {![$valid_toggles($field) state]} {
957 lappend new_desc($field) $desc
962 set obsolete [lindex [tlc::intersect3 [array names paths_by_var] [array names new_desc]] 0]
963 foreach field $obsolete {
964 $w.valid_tips detach [$valid_toggles($field) target]
966 foreach {field desclist} [array get new_desc] {
967 $w.valid_tips attach [$valid_toggles($field) target] [join $desclist \n]
972 body tlc::Form::force_form_valid_update {} { #<<<1
973 form_valid_reasons_changed
977 body tlc::Form::enabled_changed {newstate} { #<<<1
979 $w.valid_tips popdown
984 body tlc::Form::form_valid_reasons_changed {} { #<<<1
985 set newstate [$signals(form_valid) state]
987 invoke_handlers valid_status_changed $newstate {}
989 if {[$signals(enabled) state]} {
991 foreach condition_desc $valid_conditions {
992 lassign $condition_desc condition desc fields signal
993 if {![$signal state]} {
994 lappend reasons $desc
997 invoke_handlers valid_status_changed $newstate $reasons
999 invoke_handlers valid_status_changed $newstate "Form disabled"
1005 body tlc::Form::textvariable_changed {newvalue} { #<<<1
1006 log debug "$name newvalue: ($newvalue)"
1007 array set tmp $newvalue
1008 set existing [array names dat]
1009 set new [array names tmp]
1012 set removed_keys [lindex [tlc::intersect3 $existing $new] 2]
1013 foreach key $removed_keys {
1021 body tlc::Form::default_options {type args} { #<<<1
1022 set type [canonize_type $type]
1024 set default_options($type) $args
1028 body tlc::Form::canonize_type {type} { #<<<1
1031 entry {return "entry"}
1033 checkbutton {return "checkbutton"}
1034 label {return "label"}
1037 text {return "text"}
1038 button {return "button"}
1040 mycombobox {return "combobox"}
1042 dateentry {return "dateentry"}
1043 calendar {return "calendar"}
1044 fileselect {return "fileselect"}
1045 list {return "list"}
1046 lookup {return "lookup"}
1047 spinint {return "spinint"}
1048 spinner {return "spinner"}
1049 message {return "message"}
1050 intentry {return "intentry"}
1051 tagentry {return "tagentry"}
1052 radiogroup {return "radiogroup"}
1053 checkgroup {return "checkgroup"}
1055 form {return "subform"}
1056 tablelist {return "tablelist"}
1059 if {[info exists tlc::Form::custom_types($type)]} {
1062 error "Unknown type: ($type)"
1069 body tlc::Form::cleanup {} { #<<<1
1070 #log warning "$w:[tlc::stackdump]"
1072 array unset valid_toggles
1078 body tlc::Form::widget_destroyed {} { #<<<1
1081 #log warning "$w done"
1085 body tlc::Form::run_onchange_handlers {} { #<<<1
1086 set before [array get dat]
1088 set changed_fields {}
1089 set tmp [tlc::intersect3 [dict keys $old] [dict keys $before]]
1090 foreach key [lindex $tmp 0] {
1091 dict set changed_fields $key "removed"
1093 foreach key [lindex $tmp 1] {
1094 if {[dict get $old $key] ne [dict get $before $key]} {
1095 dict set changed_fields $key "changed"
1098 foreach key [lindex $tmp 2] {
1099 dict set changed_fields $key "added"
1103 set slave [interp create -safe]
1105 $slave alias element apply {
1106 {form label op args} {
1107 return [[$form path $label] $op {*}$args]
1111 #$slave alias log [code $this log] ;# is this safe?
1112 $slave alias log apply {
1118 $slave eval [list array set dat [array get dat]]
1119 $slave eval [list set old $old]
1120 $slave eval [list set new $before]
1121 $slave eval [list set changed_fields $changed_fields]
1123 foreach handler $onchange_handlers {
1124 $slave eval [list apply {
1126 if {[catch {uplevel #0 $code} errmsg options]} {
1127 log error "Error in _onchange handler: $errmsg\n$::errorInfo"
1133 set after [$slave eval {array get dat}]
1138 if {[info exists slave]} {
1139 interp delete $slave
1142 if {[info exists after]} {
1144 dict for {k v} $after {
1145 log debug "Checking ($k) ($v), existed before? ([dict exists $before $k])"
1147 ![dict exists $before $k] ||
1148 [dict get $before $k] ne [dict get $after $k]
1150 dict set changeset $k $v
1154 if {[llength $changeset] > 0} {
1155 log debug "Applying changes to dat():"
1156 array set chgset $changeset
1158 $dominos(run_onchange_handlers) lock
1160 array set dat $changeset
1162 $dominos(run_onchange_handlers) unlock
1166 set old [array get dat]