scripts/form.itk

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 # Signals fired:
   4 #       valid_status_changed(isvalid?, {reasons})       Fired when the form valid status
   5 #                                                                                               changes
   6 #       onchange(datarray)                      Fired when some form data is changed
   7 #       onchange,field(newvalue)        Fired when specific form element is changed
   8
   9 proc tlc::form {pathName args} {
  10         return [uplevel [list tlc::Form $pathName] $args]
  11 }
  12
  13 ::itk::usual tlc::Form {
  14         # This is a placeholder.  Flesh out with appropriate options
  15         keep -state
  16 }
  17
  18 class tlc::Form {
  19         inherit tlc::Border tlc::Handlers tlc::Textvariable tlc::Signalsource
  20         #inherit tlc::Formbase tlc::Border
  21
  22         constructor {args} {}
  23         destructor {}
  24
  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}
  29
  30         public {
  31                 variable schema {}
  32                 variable state  "normal"
  33                 variable name   ""
  34
  35                 method set_data {args}
  36                 method set_key {args}
  37                 method get_data {args}
  38                 method clear_data {}
  39                 method itemconfig {name args}
  40                 method path {name}
  41                 method path_by_var {varname}
  42                 method set_tips {args}
  43
  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 {}
  47                 method takefocus {}
  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}
  57         }
  58
  59         protected {
  60                 method textvariable_changed {newvalue}
  61                 method handlers_debug {lvl msg} {log $lvl $msg}
  62                 method widget_destroyed {}
  63         }
  64
  65         private {
  66                 variable dat
  67                 variable oldschema      {}
  68                 variable formvars       {}
  69                 variable paths
  70                 variable paths_by_var
  71                 variable tips           {}
  72                 variable toggles
  73                 variable valid_toggles
  74                 variable expressions
  75                 variable expression_lists
  76                 variable valid_conditions       {}
  77                 variable valid_signals
  78                 variable expr_seq       0
  79                 variable field_valid
  80                 variable dominos
  81                 variable default_options
  82                 variable onchange_handlers      {}
  83                 variable old                            {}
  84
  85                 method rerender {}
  86                 method need_rerender {}
  87                 method dat_changed {n1 n2 op}
  88                 method clear_valid_conditions {}
  89                 method check_valid {}
  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}
  95                 method cleanup {}
  96                 method run_onchange_handlers {}
  97         }
  98 }
  99
 100
 101 configbody tlc::Form::schema { #<<<1
 102         set tips        {}
 103         set schema      [tlc::decomment $schema]
 104         need_rerender
 105 }
 106
 107
 108 configbody tlc::Form::state { #<<<1
 109         log debug "state: ($state)"
 110         [stategate_ref] configure -default [expr {$state eq "normal"}]
 111 }
 112
 113
 114 configbody tlc::Form::tooltipdelay { #<<<1
 115         $w.tips configure -delay $itk_option(-tooltipdelay)
 116 }
 117
 118
 119 configbody tlc::Form::tooltiptimeout { #<<<1
 120         $w.tips configure -showtime $itk_option(-tooltiptimeout)
 121 }
 122
 123
 124 body tlc::Form::constructor {args} { #<<<1
 125         array set paths {}
 126         array set paths_by_var {}
 127         array set toggles {}
 128         array set valid_toggles {}
 129         array set expressions {}
 130         array set expression_lists {}
 131         array set valid_signals {}
 132         array set field_valid {}
 133         array set dominos {}
 134         array set default_options {}
 135
 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"
 152
 153         $signals(enabled) attach_input [stategate_ref]
 154         $signals(enabled) attach_output [code $this enabled_changed]
 155
 156         $dominos(reasons_changed) attach_output \
 157                         [code $this form_valid_reasons_changed]
 158         $signals(enabled) attach_output [list $dominos(reasons_changed) tip]
 159
 160         $dominos(need_rerender) attach_output [code $this rerender]
 161         $dominos(need_valid_desc_update) attach_output \
 162                         [code $this update_valid_desc]
 163
 164         $dominos(run_onchange_handlers) attach_output \
 165                         [code $this run_onchange_handlers]
 166
 167         itk_initialize {*}$args
 168
 169         if {$name eq ""} {
 170                 set name        $w
 171         } else {
 172                 log debug "Setting name ($name) for $w"
 173         }
 174         set baselog_instancename        $name
 175         log debug $w
 176 }
 177
 178
 179 body tlc::Form::destructor {} { #<<<1
 180         log debug $name
 181
 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
 187         cleanup
 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
 192         #       }
 193         #}
 194 }
 195
 196
 197 body tlc::Form::set_data {args} { #<<<1
 198         $dominos(need_rerender) force_if_pending
 199
 200         if {[llength $args] == 1} {
 201                 set data        [lindex $args 0]
 202         } else {
 203                 set data        $args
 204         }
 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]
 209         }
 210
 211         $signals(form_dirty) disarm
 212         array set dat $data
 213         log debug "Setting dat:"
 214         parray debug dat
 215
 216         check_valid
 217         foreach {varname exprs} [array get expression_lists] {
 218                 foreach exprname $exprs {
 219                         $expressions($exprname) reassess
 220                 }
 221         }
 222
 223         $signals(form_dirty) arm
 224         if {[$signals(form_dirty) is_armed]} {
 225                 $signals(form_dirty) set_state 0
 226         }
 227 }
 228
 229
 230 body tlc::Form::set_key {args} { #<<<1
 231         log debug $name
 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]}
 235                 2 {
 236                         set key [lindex $args 0]
 237                         set val [lindex $args 1]
 238                         return [set_data $key $val]
 239                 }
 240         }
 241
 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]
 249         } else {
 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]
 253         }
 254 }
 255
 256
 257 body tlc::Form::get_data {args} { #<<<1
 258         $dominos(need_rerender) force_if_pending
 259         parray debug dat
 260
 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]]
 268                 }
 269                 return $dat($key)
 270         } else {
 271                 set last        [array get dat]
 272                 set so_far      {}
 273                 foreach key $args {
 274                         array unset tmp
 275                         tlc::try {
 276                                 array set tmp   $last
 277                         } onerr {
 278                                 default {
 279                                         error "Cannot build array from key level [llength $so_far] \"[join $so_far ->]\": $errmsg" "" \
 280                                                         [list format_error $so_far]
 281                                 }
 282                         }
 283                         lappend so_far  $key
 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]
 287                         }
 288                         set last        $tmp($key)
 289                 }
 290                 return $last
 291         }
 292 }
 293
 294
 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)
 298 }
 299
 300
 301 body tlc::Form::rerender {} { #<<<1
 302         if {$schema eq $oldschema} return
 303         log debug $name
 304
 305         set_data        {}
 306         $signals(form_dirty) disarm
 307         catch {
 308                 destroy {*}[lindex [tlc::intersect3 [winfo children $w] [list $w.tips $w.valid_tips]] 0]
 309         }
 310
 311         # Layout context init
 312         array set layout {
 313                 label_col_args_sticky           {}
 314                 label_cell_args_sticky          {-anchor ne}
 315                 label_widget_args_sticky        {}
 316                 cell_args_sticky                        {-anchor nw}
 317                 col_args_sticky                         {}
 318         }
 319         set layout(row_args_sticky)             [list -pady $itk_option(-padding)]
 320
 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
 330         set formvars    {}
 331         set row         0
 332         set col         0
 333         set reset       1
 334         foreach {label info} $schema {
 335                 set varname             ""
 336                 set type                ""
 337                 set arglist             ""
 338
 339                 if {$reset} {
 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)
 346                 }
 347
 348                 if {[string index $label 0] eq "_"} {
 349                         switch -- $label {
 350                                 _layout         { #<<<
 351                                         if {$label eq "_layout"} {
 352                                                 switch -- [lindex $info 0] {
 353                                                         cell_args_sticky                        -
 354                                                         row_args_sticky                         -
 355                                                         col_args_sticky                         -
 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]) \
 361                                                                                 [lrange $info 1 end]
 362                                                         }
 363                                                         label_args_sticky {
 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) \
 367                                                                                 [lrange $info 1 end]
 368                                                         }
 369
 370                                                         cell_args                       -
 371                                                         row_args                        -
 372                                                         col_args                        -
 373                                                         label_col_args          -
 374                                                         label_widget_args       -
 375                                                         label_cell_args {
 376                                                                 set layout([lindex $info 0])    [lrange $info 1 end]
 377                                                                 set reset       0
 378                                                         }
 379                                                         label_args      {
 380                                                                 log warning "_layout label_args is deprecated - use label_cell_args"
 381                                                                 set layout(label_cell_args)             [lrange $info 1 end]
 382                                                                 set reset       0
 383                                                         }
 384
 385                                                         next_row                        -
 386                                                         next_col                        -
 387                                                         next_column                     {
 388                                                                 switch -- [string index $itk_option(-winding) 0] {
 389                                                                         "h" {
 390                                                                                 incr row        1
 391                                                                                 set col         0
 392                                                                                 set layout(row_args)    $layout(row_args_sticky)
 393                                                                         }
 394
 395                                                                         default -
 396                                                                         "v" {
 397                                                                                 incr col        2
 398                                                                                 set row         0
 399                                                                                 set layout(col_args)    $layout(col_args_sticky)
 400                                                                         }
 401                                                                 }
 402                                                         }
 403
 404                                                         skip_cols                       -
 405                                                         skip_columns            -
 406                                                         skip_rows                       -
 407                                                         skip_col                        -
 408                                                         skip_column                     -
 409                                                         skip_row                        {
 410                                                                 switch -- [string index $itk_option(-winding) 0] {
 411                                                                         "h" {
 412                                                                                 set amnt        [lindex $info 1]
 413                                                                                 if {$amnt eq ""} {set amnt      1}
 414                                                                                 incr col        $amnt
 415                                                                                 incr col        $amnt
 416                                                                         }
 417
 418                                                                         default -
 419                                                                         "v" {
 420                                                                                 set amnt        [lindex $info 1]
 421                                                                                 if {$amnt eq ""} {set amnt      1}
 422                                                                                 incr row        $amnt
 423                                                                         }
 424                                                                 }
 425                                                         }
 426
 427                                                         default_options         {
 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]
 431                                                         }
 432
 433                                                         default {
 434                                                                 error "Unrecognised layout parameter: ([lindex $info 0])"
 435                                                         }
 436                                                 }
 437                                         }
 438                                         #>>>
 439                                 }
 440                                 _validation - _validation_not_blank { #<<<
 441                                         if {$label eq "_validation"} {
 442                                                 valid_condition [lindex $info 0] [lindex $info 1] [lindex $info 2]
 443                                         }
 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 {}"
 448                                                         valid_condition \
 449                                                                         $condition \
 450                                                                         [string map [list %1 $labelname] $template] \
 451                                                                         [list $varname]
 452                                                 }
 453                                         }
 454                                         #>>>
 455                                 }
 456                                 _tips - _tooltips { #<<<
 457                                         set_tips $info
 458                                         #>>>
 459                                 }
 460                                 _defaults { #<<<
 461                                         log debug "Setting defaults: ($info)"
 462                                         array set dat   $info
 463                                         parray debug dat
 464                                         #>>>
 465                                 }
 466                                 _default_options { #<<<
 467                                         set type        [canonize_type [lindex $info 0]]
 468                                         set default_options($type)      [lrange $info 1 end]
 469                                         #>>>
 470                                 }
 471                                 _onchange { #<<<
 472                                         lappend onchange_handlers $info
 473                                         #>>>
 474                                 }
 475                                 default {
 476                                         error "Invalid meta directive \"$label\", must be one of _layout, _validation, _validation_not_blank, _tips or _tooltips" "" [list invalid_meta_directive $label]
 477                                 }
 478                         }
 479
 480                         continue
 481                 }
 482
 483                 set reset       1
 484
 485                 lassign $info varname type
 486                 lappend formvars        $varname
 487                 set type                        [canonize_type $type]
 488
 489                 if {[info exists default_options($type)]} {
 490                         set arglist     [concat $default_options($type) [lrange $info 2 end]]
 491                 } else {
 492                         set arglist     [lrange $info 2 end]
 493                 }
 494
 495                 if {[string index $label 0] eq " "} {
 496                         ttk::label $w.$row,$col,l -text "" -width 0
 497                 } else {
 498                         ttk::label $w.$row,$col,l -text $label
 499                 }
 500                 if {[llength $layout(label_widget_args)] > 0} {
 501                         $w.$row,$col,l configure {*}$layout(label_widget_args)
 502                 }
 503
 504                 if {![info exists dat($varname)]} {
 505                         set dat($varname)       ""
 506                 }
 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
 511
 512                         # Works, but ugly
 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]]
 516                 } else {
 517                         set scoped_varname      [scope dat($varname)]
 518                 }
 519
 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 \
 524                                 $w.$row,$col,l \
 525                                         -foreground {red black}
 526                 #tlc::StateToggle #auto valid_toggles($varname) \
 527                 #                       -mode "or" -default 1 \
 528                 #               $w.$row,$col,l
 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 {
 533                         {widget newstate} {
 534                                 if {![winfo exists $widget]} return
 535                                 if {$newstate} {
 536                                         $widget state !invalid
 537                                 } else {
 538                                         $widget state invalid
 539                                 }
 540                         }
 541                 } $w.$row,$col,l]
 542
 543                 $valid_toggles($varname) attach_output \
 544                                 [list $dominos(reasons_changed) tip]
 545
 546                 set toggle                      {-state {disabled normal}}
 547                 switch -- $type {
 548                         entry {
 549                                 ttk::entry $w.$row,$col,v -textvariable $scoped_varname \
 550                                                 {*}$arglist
 551                         }
 552
 553                         checkbutton {
 554                                 ttk::checkbutton $w.$row,$col,v -variable $scoped_varname \
 555                                                 {*}$arglist
 556                         }
 557
 558                         label {
 559                                 ttk::label $w.$row,$col,v -textvariable $scoped_varname \
 560                                                 -justify left \
 561                                                 -font [$tlc::theme setting boldfont] \
 562                                                 {*}$arglist
 563                         }
 564
 565                         text {
 566                                 tlc::vartextbox $w.$row,$col,v -textvariable $scoped_varname \
 567                                                 {*}$arglist
 568                         }
 569
 570                         button {
 571                                 ttk::button $w.$row,$col,v {*}$arglist
 572                         }
 573
 574                         combobox {
 575                                 tlc::mycombobox $w.$row,$col,v -textvariable $scoped_varname \
 576                                                 {*}$arglist
 577                         }
 578
 579                         dateentry {
 580                                 tlc::Dateentry $w.$row,$col,v -textvariable $scoped_varname \
 581                                                 {*}$arglist
 582                         }
 583
 584                         calendar {
 585                                 tlc::Calendar $w.$row,$col,v -command [code set dat($varname)] \
 586                                                 {*}$arglist
 587                         }
 588
 589                         fileselect {
 590                                 tlc::Fileselectbox $w.$row,$col,v \
 591                                                 -textvariable $scoped_varname \
 592                                                 {*}$arglist
 593                         }
 594
 595                         list {
 596                                 tlc::Browse_tktreectrl_list $w.$row,$col,v \
 597                                                 -textvariable $scoped_varname \
 598                                                 {*}$arglist
 599                         }
 600
 601                         lookup {
 602                                 tlc::Lookup $w.$row,$col,v \
 603                                                 -textvariable $scoped_varname \
 604                                                 {*}$arglist
 605                         }
 606
 607                         spinint {
 608                                 tlc::Spinint $w.$row,$col,v \
 609                                                 -textvariable $scoped_varname \
 610                                                 {*}$arglist
 611                         }
 612
 613                         spinner {
 614                                 tlc::Spinner $w.$row,$col,v \
 615                                                 -textvariable $scoped_varname \
 616                                                 {*}$arglist
 617                                 # TODO: wire valid_signal?
 618                         }
 619
 620                         message {
 621                                 message $w.$row,$col,v \
 622                                                 -textvariable $scoped_varname \
 623                                                 -font [$tlc::theme setting boldfont] \
 624                                                 {*}$arglist
 625                                 set toggle      {}
 626                         }
 627
 628                         intentry {
 629                                 ttk::entry $w.$row,$col,v -textvariable $scoped_varname \
 630                                                 -validate all \
 631                                                 -validatecommand {string is integer {%P}} \
 632                                                 {*}$arglist
 633                         }
 634
 635                         tagentry {
 636                                 Tagentry $w.$row,$col,v \
 637                                                 -textvariable $scoped_varname \
 638                                                 {*}$arglist
 639                         }
 640
 641                         radiogroup {
 642                                 tlc::Radiogroup $w.$row,$col,v \
 643                                                 -textvariable $scoped_varname \
 644                                                 {*}$arglist
 645                         }
 646
 647                         checkgroup {
 648                                 tlc::Checkgroup $w.$row,$col,v \
 649                                                 -textvariable $scoped_varname \
 650                                                 {*}$arglist
 651                         }
 652
 653                         subform {
 654                                 tlc::Form $w.$row,$col,v -textvariable $scoped_varname \
 655                                                 -name "$name -> $varname" \
 656                                                 {*}$arglist
 657                                 valid_signal [$w.$row,$col,v signal_ref form_valid] "" $varname
 658                         }
 659
 660                         tablelist {
 661                                 tlc::Tablelist $w.$row,$col,v \
 662                                                 -textvariable $scoped_varname \
 663                                                 {*}$arglist
 664                                 # TODO: wire valid_signal?
 665                         }
 666
 667                         default {
 668                                 if {[info exists tlc::Form::custom_types($type)]} {
 669                                         $tlc::Form::custom_types($type) $w.$row,$col,v \
 670                                                         -textvariable $scoped_varname \
 671                                                         {*}$arglist
 672                                 } else {
 673                                         log error "Unknown type: ($type)"
 674                                         continue
 675                                 }
 676                         }
 677                 }
 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 \
 681                                 {*}$toggle
 682                 $toggles($varname) attach_signal $signals(enabled)
 683
 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
 687
 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)
 692
 693                 switch -- [string index $itk_option(-winding) 0] {
 694                         "h" {
 695                                 incr col 2
 696                         }
 697
 698                         default -
 699                         "v" {
 700                                 incr row
 701                         }
 702                 }
 703         }
 704
 705         set_tips $tips
 706
 707         update idletasks
 708         if {![info exists signals(form_dirty)]} {
 709                 log error "Freak out - signals(form_dirty) missing\n$w\n[tlc::stackdump]"
 710                 return
 711         }
 712         run_onchange_handlers
 713
 714         $signals(form_dirty) arm
 715         $signals(form_dirty) set_state 0
 716 }
 717
 718
 719 body tlc::Form::takefocus {} { #<<<1
 720         $dominos(need_rerender) force_if_pending
 721         if {[winfo exists $w.0,0,v]} {
 722                 focus $w.0,0,v
 723         }
 724 }
 725
 726
 727 body tlc::Form::need_rerender {} { #<<<1
 728         $dominos(need_rerender) tip
 729 }
 730
 731
 732 body tlc::Form::itemconfig {name args} { #<<<1
 733         set path        [path $name]
 734         $path configure {*}$args
 735 }
 736
 737
 738 body tlc::Form::path {name} { #<<<1
 739         $dominos(need_rerender) force_if_pending
 740
 741         if {[string is integer -strict $name]} {
 742                 if {[winfo exists $w.$name,0,v]} {
 743                         return $w.$name,0,v
 744                 } else {
 745                         error "No such item index: ($name)"
 746                 }
 747         } elseif {[regexp {[0-9]+,[0-9]+} $name]} {
 748                 lassign [split $name ,] r c
 749                 if {[winfo exists $w.$r,$c,v]} {
 750                         return $w.$r,$c,v
 751                 } else {
 752                         error "No such item index: ($name)"
 753                 }
 754         } else {
 755                 if {![info exists paths($name)]} {
 756                         error "No such form item: ($name), choose from (\"[join [array names paths] {", "}]\")"
 757                 }
 758                 return $paths($name)
 759         }
 760 }
 761
 762
 763 body tlc::Form::changed_dom_ref {} { #<<<1
 764         return $dominos(changed)
 765 }
 766
 767
 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
 771                 # (for convenience)
 772                 set args        [lindex $args 0]
 773         }
 774         foreach {label tip} $args {
 775                 set widget      [path $label]
 776                 $w.tips attach $widget $tip
 777         }
 778         set tips        $args
 779 }
 780
 781
 782 body tlc::Form::mark_dirty {state} { #<<<1
 783         log debug
 784         $signals(form_dirty) set_state $state
 785 }
 786
 787
 788 body tlc::Form::path_by_var {varname} { #<<<1
 789         $dominos(need_rerender) force_if_pending
 790
 791         if {![info exists paths_by_var($varname)]} {
 792                 error "No such form item: ($varname)" "" \
 793                                 [list invalid_form_item $varname]
 794         }
 795         return $paths_by_var($varname)
 796 }
 797
 798 body tlc::Form::dat_changed {n1 n2 op} { #<<<1
 799         if {$op eq "w"} {
 800                 log debug "dat($n2) changed: ($dat($n2))"
 801         } elseif {$op eq "u"} {
 802                 log debug "dat($n2) unset"
 803         }
 804         set_textvariable [get_data]
 805
 806         if {[$signals(form_dirty) is_armed]} {
 807                 check_valid
 808                 if {[info exists dat($n2)]} {
 809                         if {[info exists expression_lists($n2)]} {
 810                                 foreach exprname $expression_lists($n2) {
 811                                         $expressions($exprname) reassess
 812                                 }
 813                         }
 814                         invoke_handlers onchange,$n2 $dat($n2)
 815                 }
 816                 invoke_handlers onchange [array get dat]
 817                 $dominos(run_onchange_handlers) tip
 818
 819                 $signals(form_dirty) set_state 1
 820         }
 821 }
 822
 823
 824 body tlc::Form::clear_data {} { #<<<1
 825         log debug $name
 826         $signals(form_dirty) disarm
 827         #array unset dat
 828         #array set dat {}
 829         # TODO: figure out why this is necessary
 830         foreach key [array names dat] {
 831                 set dat($key)   ""
 832         }
 833
 834         #array unset toggles
 835         #array set toggles {}
 836         #array unset expressions
 837         $signals(form_dirty) set_state 0
 838         $signals(form_dirty) arm
 839 }
 840
 841
 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
 846 }
 847
 848
 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
 858
 859         return $expressions($exprname)
 860 }
 861
 862
 863 body tlc::Form::varname_from_path {path} { #<<<1
 864         set ok  0
 865         foreach {v p} [array get paths_by_var] {
 866                 if {$p eq $path} {
 867                         set varname     $v
 868                         set ok  1
 869                         break
 870                 }
 871         }
 872
 873         if {$ok} {
 874                 return $varname
 875         } else {
 876                 error "No varname known for path: ($path)"
 877         }
 878 }
 879
 880
 881 body tlc::Form::arm_dirty {state} { #<<<1
 882         log debug
 883         if {$state} {
 884                 $signals(form_dirty) arm
 885         } else {
 886                 $signals(form_dirty) disarm
 887         }
 888 }
 889
 890
 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)
 894 }
 895
 896
 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)]
 900
 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]
 905         }
 906
 907         check_valid
 908
 909         $signals(form_valid) attach_input $valid_signals($new_condition)
 910 }
 911
 912
 913 body tlc::Form::valid_signal {signal desc fields} { #<<<1
 914         $dominos(need_rerender) force_if_pending
 915
 916         lappend valid_conditions        [list {} $desc $fields $signal]
 917
 918         foreach field $fields {
 919                 $field_valid($field) attach_input $signal
 920                 $valid_toggles($field) attach_output \
 921                                 [code $this valid_changed {} $desc $fields]
 922         }
 923
 924         $signals(form_valid) attach_input $signal
 925 }
 926
 927
 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]
 933                 }
 934         }
 935 }
 936
 937
 938 body tlc::Form::clear_valid_conditions {} { #<<<1
 939         set valid_conditions    {}
 940         check_valid
 941 }
 942
 943
 944
 945 body tlc::Form::valid_changed {condition desc fields newstate} { #<<<1
 946         $dominos(need_valid_desc_update) tip
 947 }
 948
 949
 950 body tlc::Form::update_valid_desc {} { #<<<1
 951         array set new_desc      {}
 952
 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
 958                         }
 959                 }
 960         }
 961
 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]
 965         }
 966         foreach {field desclist} [array get new_desc] {
 967                 $w.valid_tips attach [$valid_toggles($field) target] [join $desclist \n]
 968         }
 969 }
 970
 971
 972 body tlc::Form::force_form_valid_update {} { #<<<1
 973         form_valid_reasons_changed
 974 }
 975
 976
 977 body tlc::Form::enabled_changed {newstate} { #<<<1
 978         if {!($newstate)} {
 979                 $w.valid_tips popdown
 980         }
 981 }
 982
 983
 984 body tlc::Form::form_valid_reasons_changed {} { #<<<1
 985         set newstate    [$signals(form_valid) state]
 986         if {$newstate} {
 987                 invoke_handlers valid_status_changed $newstate {}
 988         } else {
 989                 if {[$signals(enabled) state]} {
 990                         set reasons     {}
 991                         foreach condition_desc $valid_conditions {
 992                                 lassign $condition_desc condition desc fields signal
 993                                 if {![$signal state]} {
 994                                         lappend reasons $desc
 995                                 }
 996                         }
 997                         invoke_handlers valid_status_changed $newstate $reasons
 998                 } else {
 999                         invoke_handlers valid_status_changed $newstate "Form disabled"
1000                 }
1001         }
1002 }
1003
1004
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]
1010         array unset tmp
1011
1012         set removed_keys        [lindex [tlc::intersect3 $existing $new] 2]
1013         foreach key $removed_keys {
1014                 set dat($key)   ""
1015         }
1016
1017         set_data $newvalue
1018 }
1019
1020
1021 body tlc::Form::default_options {type args} { #<<<1
1022         set type        [canonize_type $type]
1023
1024         set default_options($type)      $args
1025 }
1026
1027
1028 body tlc::Form::canonize_type {type} { #<<<1
1029         switch -- $type {
1030                 ""                      -
1031                 entry           {return "entry"}
1032                 checkbox        -
1033                 checkbutton     {return "checkbutton"}
1034                 label           {return "label"}
1035                 vartextbox      -
1036                 textbox         -
1037                 text            {return "text"}
1038                 button          {return "button"}
1039                 combobox        -
1040                 mycombobox      {return "combobox"}
1041                 date            -
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"}
1054                 subform         -
1055                 form            {return "subform"}
1056                 tablelist       {return "tablelist"}
1057
1058                 default {
1059                         if {[info exists tlc::Form::custom_types($type)]} {
1060                                 return $type
1061                         } else {
1062                                 error "Unknown type: ($type)"
1063                         }
1064                 }
1065         }
1066 }
1067
1068
1069 body tlc::Form::cleanup {} { #<<<1
1070         #log warning "$w:[tlc::stackdump]"
1071         array unset toggles
1072         array unset valid_toggles
1073         array unset signals
1074         array unset dominos
1075 }
1076
1077
1078 body tlc::Form::widget_destroyed {} { #<<<1
1079         #log warning $w
1080         cleanup
1081         #log warning "$w done"
1082 }
1083
1084
1085 body tlc::Form::run_onchange_handlers {} { #<<<1
1086         set before      [array get dat]
1087
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"
1092         }
1093         foreach key [lindex $tmp 1] {
1094                 if {[dict get $old $key] ne [dict get $before $key]} {
1095                         dict set changed_fields $key    "changed"
1096                 }
1097         }
1098         foreach key [lindex $tmp 2] {
1099                 dict set changed_fields $key    "added"
1100         }
1101
1102         tlc::try {
1103                 set slave       [interp create -safe]
1104
1105                 $slave alias element apply {
1106                         {form label op args} {
1107                                 return [[$form path $label] $op {*}$args]
1108                         }
1109                 } $this
1110
1111                 #$slave alias log [code $this log]      ;# is this safe?
1112                 $slave alias log apply {
1113                         {lvl msg} {
1114                                 puts stderr $msg
1115                         }
1116                 }
1117
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]
1122
1123                 foreach handler $onchange_handlers {
1124                         $slave eval [list apply {
1125                                 {code} {
1126                                         if {[catch {uplevel #0 $code} errmsg options]} {
1127                                                 log error "Error in _onchange handler: $errmsg\n$::errorInfo"
1128                                         }
1129                                 }
1130                         } $handler]
1131                 }
1132
1133                 set after       [$slave eval {array get dat}]
1134         } onerr {
1135                 default {STDMSG}
1136         }
1137
1138         if {[info exists slave]} {
1139                 interp delete $slave
1140         }
1141
1142         if {[info exists after]} {
1143                 set changeset   {}
1144                 dict for {k v} $after {
1145                         log debug "Checking ($k) ($v), existed before? ([dict exists $before $k])"
1146                         if {
1147                                 ![dict exists $before $k] ||
1148                                 [dict get $before $k] ne [dict get $after $k]
1149                         } {
1150                                 dict set changeset $k $v
1151                         }
1152                 }
1153
1154                 if {[llength $changeset] > 0} {
1155                         log debug "Applying changes to dat():"
1156                         array set chgset        $changeset
1157                         parray debug chgset
1158                         $dominos(run_onchange_handlers) lock
1159                         arm_dirty 0
1160                         array set dat   $changeset
1161                         arm_dirty 1
1162                         $dominos(run_onchange_handlers) unlock
1163                 }
1164         }
1165
1166         set old [array get dat]
1167 }
1168
1169