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         $dominos(run_onchange_handlers) tip
 217
 218         check_valid
 219         foreach {varname exprs} [array get expression_lists] {
 220                 foreach exprname $exprs {
 221                         $expressions($exprname) reassess
 222                 }
 223         }
 224
 225         $signals(form_dirty) arm
 226         if {[$signals(form_dirty) is_armed]} {
 227                 $signals(form_dirty) set_state 0
 228         }
 229 }
 230
 231
 232 body tlc::Form::set_key {args} { #<<<1
 233         log debug $name
 234         switch -- [llength $args] {
 235                 0 {error "No key specified" "" [list syntax_error no_key_specified]}
 236                 1 {error "No value specified" "" [list syntax_error no_value_specified]}
 237                 2 {
 238                         set key [lindex $args 0]
 239                         set val [lindex $args 1]
 240                         return [set_data $key $val]
 241                 }
 242         }
 243
 244         set key         [lindex $args 0]
 245         set keys        [lrange $args 1 end-1]
 246         set val         [lindex $args end]
 247         set handler     [path_by_var $key]
 248         if {[itcl::is object $handler] && [$handler isa tlc::Form]} {
 249                 $handler set_key {*}$keys $val
 250                 set dat($key)   [$handler get_data]
 251         } else {
 252                 # TODO: recursive setter that composes the nested array list on unwind
 253                 error "Only subforms are currently supported for deep key sets" "" \
 254                                 [list not_implemented]
 255         }
 256 }
 257
 258
 259 body tlc::Form::get_data {args} { #<<<1
 260         $dominos(need_rerender) force_if_pending
 261         parray debug dat
 262
 263         if {[llength $args] == 0} {
 264                 return [array get dat]
 265         } elseif {[llength $args] == 1} {
 266                 set key         [lindex $args 0]
 267                 if {![info exists dat($key)]} {
 268                         error "Bad key: \"$key\", should be one of [join [array names tmp] {, }]" "" \
 269                                         [list bad_key [list $key]]
 270                 }
 271                 return $dat($key)
 272         } else {
 273                 set last        [array get dat]
 274                 set so_far      {}
 275                 foreach key $args {
 276                         array unset tmp
 277                         tlc::try {
 278                                 array set tmp   $last
 279                         } onerr {
 280                                 default {
 281                                         error "Cannot build array from key level [llength $so_far] \"[join $so_far ->]\": $errmsg" "" \
 282                                                         [list format_error $so_far]
 283                                 }
 284                         }
 285                         lappend so_far  $key
 286                         if {![info exists tmp($key)]} {
 287                                 error "Bad key: \"[join $so_far ->]\", should be one of [join [array names tmp] {, }]" "" \
 288                                                 [list bad_key $so_far]
 289                         }
 290                         set last        $tmp($key)
 291                 }
 292                 return $last
 293         }
 294 }
 295
 296
 297 body tlc::Form::dirty_gate_ref {} { #<<<1
 298         log warning "dirty_gate_ref deprecated, use \"signal_ref form_dirty\" instead"
 299         return $signals(form_dirty)
 300 }
 301
 302
 303 body tlc::Form::rerender {} { #<<<1
 304         if {$schema eq $oldschema} return
 305         log debug $name
 306
 307         set_data        {}
 308         $signals(form_dirty) disarm
 309         catch {
 310                 destroy {*}[lindex [tlc::intersect3 [winfo children $w] [list $w.tips $w.valid_tips]] 0]
 311         }
 312
 313         # Layout context init
 314         array set layout {
 315                 label_col_args_sticky           {}
 316                 label_cell_args_sticky          {-anchor ne}
 317                 label_widget_args_sticky        {}
 318                 cell_args_sticky                        {-anchor nw}
 319                 col_args_sticky                         {}
 320         }
 321         set layout(row_args_sticky)             [list -pady $itk_option(-padding)]
 322
 323         catch {unset paths}; array set paths {}
 324         catch {unset paths_by_var}; array set paths_by_var {}
 325         catch {unset toggles}; array set toggles {}
 326         catch {unset valid_toggles}; array set valid_toggles {}
 327         catch {unset field_valid}; array set field_valid {}
 328         catch {unset valid_signals}; array set valid_signals {}
 329         catch {unset expressions}
 330         catch {unset expression_lists}
 331         clear_valid_conditions
 332         set formvars    {}
 333         set row         0
 334         set col         0
 335         set reset       1
 336         foreach {label info} $schema {
 337                 set varname             ""
 338                 set type                ""
 339                 set arglist             ""
 340
 341                 if {$reset} {
 342                         set layout(label_cell_args)             $layout(label_cell_args_sticky)
 343                         set layout(label_col_args)              $layout(label_col_args_sticky)
 344                         set layout(label_widget_args)   $layout(label_widget_args_sticky)
 345                         set layout(cell_args)                   $layout(cell_args_sticky)
 346                         set layout(row_args)                    $layout(row_args_sticky)
 347                         set layout(col_args)                    $layout(col_args_sticky)
 348                 }
 349
 350                 if {[string index $label 0] eq "_"} {
 351                         switch -- $label {
 352                                 _layout         { #<<<
 353                                         if {$label eq "_layout"} {
 354                                                 switch -- [lindex $info 0] {
 355                                                         cell_args_sticky                        -
 356                                                         row_args_sticky                         -
 357                                                         col_args_sticky                         -
 358                                                         label_cell_args_sticky          -
 359                                                         label_widget_args_sticky        -
 360                                                         label_col_args_sticky           {
 361                                                                 set layout([lindex $info 0])    [lrange $info 1 end]
 362                                                                 set layout([string range [lindex $info 0] 0 end-7]) \
 363                                                                                 [lrange $info 1 end]
 364                                                         }
 365                                                         label_args_sticky {
 366                                                                 log warning "_layout label_args_sticky is deprecated - use label_cell_args_sticky"
 367                                                                 set layout(label_cell_args_sticky)      [lrange $info 1 end]
 368                                                                 set layout(label_cell_args) \
 369                                                                                 [lrange $info 1 end]
 370                                                         }
 371
 372                                                         cell_args                       -
 373                                                         row_args                        -
 374                                                         col_args                        -
 375                                                         label_col_args          -
 376                                                         label_widget_args       -
 377                                                         label_cell_args {
 378                                                                 set layout([lindex $info 0])    [lrange $info 1 end]
 379                                                                 set reset       0
 380                                                         }
 381                                                         label_args      {
 382                                                                 log warning "_layout label_args is deprecated - use label_cell_args"
 383                                                                 set layout(label_cell_args)             [lrange $info 1 end]
 384                                                                 set reset       0
 385                                                         }
 386
 387                                                         next_row                        -
 388                                                         next_col                        -
 389                                                         next_column                     {
 390                                                                 switch -- [string index $itk_option(-winding) 0] {
 391                                                                         "h" {
 392                                                                                 incr row        1
 393                                                                                 set col         0
 394                                                                                 set layout(row_args)    $layout(row_args_sticky)
 395                                                                         }
 396
 397                                                                         default -
 398                                                                         "v" {
 399                                                                                 incr col        2
 400                                                                                 set row         0
 401                                                                                 set layout(col_args)    $layout(col_args_sticky)
 402                                                                         }
 403                                                                 }
 404                                                         }
 405
 406                                                         skip_cols                       -
 407                                                         skip_columns            -
 408                                                         skip_rows                       -
 409                                                         skip_col                        -
 410                                                         skip_column                     -
 411                                                         skip_row                        {
 412                                                                 switch -- [string index $itk_option(-winding) 0] {
 413                                                                         "h" {
 414                                                                                 set amnt        [lindex $info 1]
 415                                                                                 if {$amnt eq ""} {set amnt      1}
 416                                                                                 incr col        $amnt
 417                                                                                 incr col        $amnt
 418                                                                         }
 419
 420                                                                         default -
 421                                                                         "v" {
 422                                                                                 set amnt        [lindex $info 1]
 423                                                                                 if {$amnt eq ""} {set amnt      1}
 424                                                                                 incr row        $amnt
 425                                                                         }
 426                                                                 }
 427                                                         }
 428
 429                                                         default_options         {
 430                                                                 log warning "default_options mode of _layout is deprecated.  Use top level directive _default_options instead"
 431                                                                 set type        [canonize_type [lindex $info 1]]
 432                                                                 set default_options($type)      [lrange $info 2 end]
 433                                                         }
 434
 435                                                         default {
 436                                                                 error "Unrecognised layout parameter: ([lindex $info 0])"
 437                                                         }
 438                                                 }
 439                                         }
 440                                         #>>>
 441                                 }
 442                                 _validation - _validation_not_blank { #<<<
 443                                         if {$label eq "_validation"} {
 444                                                 valid_condition [lindex $info 0] [lindex $info 1] [lindex $info 2]
 445                                         }
 446                                         if {$label eq "_validation_not_blank"} {
 447                                                 set template    [lindex $info 0]
 448                                                 foreach {labelname varname} [lrange $info 1 end] {
 449                                                         set condition   "\[string trim \$dat([string map {{ } {\ } {)} {\)}} $varname])\] ne {}"
 450                                                         valid_condition \
 451                                                                         $condition \
 452                                                                         [string map [list %1 $labelname] $template] \
 453                                                                         [list $varname]
 454                                                 }
 455                                         }
 456                                         #>>>
 457                                 }
 458                                 _tips - _tooltips { #<<<
 459                                         set_tips $info
 460                                         #>>>
 461                                 }
 462                                 _defaults { #<<<
 463                                         log debug "Setting defaults: ($info)"
 464                                         array set dat   $info
 465                                         parray debug dat
 466                                         #>>>
 467                                 }
 468                                 _default_options { #<<<
 469                                         set type        [canonize_type [lindex $info 0]]
 470                                         set default_options($type)      [lrange $info 1 end]
 471                                         #>>>
 472                                 }
 473                                 _onchange { #<<<
 474                                         lappend onchange_handlers $info
 475                                         #>>>
 476                                 }
 477                                 default {
 478                                         error "Invalid meta directive \"$label\", must be one of _layout, _validation, _validation_not_blank, _tips or _tooltips" "" [list invalid_meta_directive $label]
 479                                 }
 480                         }
 481
 482                         continue
 483                 }
 484
 485                 set reset       1
 486
 487                 lassign $info varname type
 488                 lappend formvars        $varname
 489                 set type                        [canonize_type $type]
 490
 491                 if {[info exists default_options($type)]} {
 492                         set arglist     [concat $default_options($type) [lrange $info 2 end]]
 493                 } else {
 494                         set arglist     [lrange $info 2 end]
 495                 }
 496
 497                 if {[string index $label 0] eq " "} {
 498                         ttk::label $w.$row,$col,l -text "" -width 0
 499                 } else {
 500                         ttk::label $w.$row,$col,l -text $label
 501                 }
 502                 if {[llength $layout(label_widget_args)] > 0} {
 503                         $w.$row,$col,l configure {*}$layout(label_widget_args)
 504                 }
 505
 506                 if {![info exists dat($varname)]} {
 507                         set dat($varname)       ""
 508                 }
 509                 if {[string first " " $varname] != -1} {
 510                         # Itcl bug (still as of 3.3) prevents scope / resolver working
 511                         # with arrays whose keys contain spaces.  We craft our own here
 512                         # that works with the resolver
 513
 514                         # Works, but ugly
 515                         #set scoped_varname     "[list @itcl $this] [namespace current]::dat($varname)"
 516                         set tmp         [scope dat($varname)]
 517                         set scoped_varname      [concat [lrange $tmp 0 1] [lindex $tmp 2]]
 518                 } else {
 519                         set scoped_varname      [scope dat($varname)]
 520                 }
 521
 522                 tlc::Gate #auto field_valid($varname) -name "$w field_valid $varname" \
 523                                 -mode "and" -default 1
 524                 tlc::StateToggle #auto valid_toggles($varname) \
 525                                         -mode "or" -default 1 \
 526                                 $w.$row,$col,l \
 527                                         -foreground {red black}
 528                 #tlc::StateToggle #auto valid_toggles($varname) \
 529                 #                       -mode "or" -default 1 \
 530                 #               $w.$row,$col,l
 531                 ##                      -font [list [$tlc::theme setting boldfont] [$tlc::theme setting font]]
 532                 $valid_toggles($varname) attach_signal $signals(enabled) inverted
 533                 $valid_toggles($varname) attach_signal $field_valid($varname)
 534                 $valid_toggles($varname) attach_output [list apply {
 535                         {widget newstate} {
 536                                 if {![winfo exists $widget]} return
 537                                 if {$newstate} {
 538                                         $widget state !invalid
 539                                 } else {
 540                                         $widget state invalid
 541                                 }
 542                         }
 543                 } $w.$row,$col,l]
 544
 545                 $valid_toggles($varname) attach_output \
 546                                 [list $dominos(reasons_changed) tip]
 547
 548                 set toggle                      {-state {disabled normal}}
 549                 switch -- $type {
 550                         entry {
 551                                 ttk::entry $w.$row,$col,v -textvariable $scoped_varname \
 552                                                 {*}$arglist
 553                         }
 554
 555                         checkbutton {
 556                                 ttk::checkbutton $w.$row,$col,v -variable $scoped_varname \
 557                                                 {*}$arglist
 558                         }
 559
 560                         label {
 561                                 ttk::label $w.$row,$col,v -textvariable $scoped_varname \
 562                                                 -justify left \
 563                                                 -font [$tlc::theme setting boldfont] \
 564                                                 {*}$arglist
 565                         }
 566
 567                         text {
 568                                 tlc::vartextbox $w.$row,$col,v -textvariable $scoped_varname \
 569                                                 {*}$arglist
 570                         }
 571
 572                         button {
 573                                 ttk::button $w.$row,$col,v {*}$arglist
 574                         }
 575
 576                         mycombobox {
 577                                 tlc::mycombobox $w.$row,$col,v -textvariable $scoped_varname \
 578                                                 {*}$arglist
 579                         }
 580
 581                         combobox {
 582                                 tlc::Combobox $w.$row,$col,v -textvariable $scoped_varname \
 583                                                 {*}$arglist
 584                         }
 585
 586                         dateentry {
 587                                 tlc::Dateentry $w.$row,$col,v -textvariable $scoped_varname \
 588                                                 {*}$arglist
 589                         }
 590
 591                         calendar {
 592                                 tlc::Calendar $w.$row,$col,v -command [code set dat($varname)] \
 593                                                 {*}$arglist
 594                         }
 595
 596                         fileselect {
 597                                 tlc::Fileselectbox $w.$row,$col,v \
 598                                                 -textvariable $scoped_varname \
 599                                                 {*}$arglist
 600                         }
 601
 602                         list {
 603                                 tlc::Browse_tktreectrl_list $w.$row,$col,v \
 604                                                 -textvariable $scoped_varname \
 605                                                 {*}$arglist
 606                         }
 607
 608                         lookup {
 609                                 tlc::Lookup $w.$row,$col,v \
 610                                                 -textvariable $scoped_varname \
 611                                                 {*}$arglist
 612                         }
 613
 614                         spinint {
 615                                 tlc::Spinint $w.$row,$col,v \
 616                                                 -textvariable $scoped_varname \
 617                                                 {*}$arglist
 618                         }
 619
 620                         spinner {
 621                                 tlc::Spinner $w.$row,$col,v \
 622                                                 -textvariable $scoped_varname \
 623                                                 {*}$arglist
 624                                 # TODO: wire valid_signal?
 625                         }
 626
 627                         message {
 628                                 message $w.$row,$col,v \
 629                                                 -textvariable $scoped_varname \
 630                                                 -font [$tlc::theme setting boldfont] \
 631                                                 {*}$arglist
 632                                 set toggle      {}
 633                         }
 634
 635                         intentry {
 636                                 ttk::entry $w.$row,$col,v -textvariable $scoped_varname \
 637                                                 -validate all \
 638                                                 -validatecommand {string is integer {%P}} \
 639                                                 {*}$arglist
 640                         }
 641
 642                         tagentry {
 643                                 tlc::Tagentry $w.$row,$col,v \
 644                                                 -textvariable $scoped_varname \
 645                                                 {*}$arglist
 646                         }
 647
 648                         radiogroup {
 649                                 tlc::Radiogroup $w.$row,$col,v \
 650                                                 -textvariable $scoped_varname \
 651                                                 {*}$arglist
 652                         }
 653
 654                         checkgroup {
 655                                 tlc::Checkgroup $w.$row,$col,v \
 656                                                 -textvariable $scoped_varname \
 657                                                 {*}$arglist
 658                         }
 659
 660                         subform {
 661                                 tlc::Form $w.$row,$col,v -textvariable $scoped_varname \
 662                                                 -name "$name -> $varname" \
 663                                                 {*}$arglist
 664                                 valid_signal [$w.$row,$col,v signal_ref form_valid] "" $varname
 665                         }
 666
 667                         tablelist {
 668                                 tlc::Tablelist $w.$row,$col,v \
 669                                                 -textvariable $scoped_varname \
 670                                                 {*}$arglist
 671                                 # TODO: wire valid_signal?
 672                         }
 673
 674                         default {
 675                                 if {[info exists tlc::Form::custom_types($type)]} {
 676                                         $tlc::Form::custom_types($type) $w.$row,$col,v \
 677                                                         -textvariable $scoped_varname \
 678                                                         {*}$arglist
 679                                 } else {
 680                                         log error "Unknown type: ($type)"
 681                                         continue
 682                                 }
 683                         }
 684                 }
 685
 686                 # Automatically wire in the element's valid signal, if it has one <<<
 687                 if {
 688                         [itcl::is object $w.$row,$col,v] &&
 689                         [$w.$row,$col,v isa tlc::Signalsource] &&
 690                         "valid" in [$w.$row,$col,v signals_available]
 691                 } {
 692                         valid_signal \
 693                                         [$w.$row,$col,v signal_ref valid] \
 694                                         "$label is invalid" \
 695                                         [list $varname]
 696                 }
 697                 # Automatically wire in the element's valid signal, if it has one >>>
 698
 699                 set paths($label)                       $w.$row,$col,v
 700                 set paths_by_var($varname)      $w.$row,$col,v
 701                 tlc::StateToggle #auto toggles($varname) $w.$row,$col,v \
 702                                 {*}$toggle
 703                 $toggles($varname) attach_signal $signals(enabled)
 704
 705                 set dc          [expr {$col+1}]
 706                 blt::table $w $w.$row,$col,l    $row,$col       {*}$layout(label_cell_args)
 707                 blt::table configure $w         c$col   -resize none
 708
 709                 blt::table $w $w.$row,$col,v    $row,$dc        {*}$layout(cell_args)
 710                 blt::table configure $w         c$col   {*}$layout(label_col_args)
 711                 blt::table configure $w         c$dc    {*}$layout(col_args)
 712                 blt::table configure $w         r$row   {*}$layout(row_args)
 713
 714                 switch -- [string index $itk_option(-winding) 0] {
 715                         "h" {
 716                                 incr col 2
 717                         }
 718
 719                         default -
 720                         "v" {
 721                                 incr row
 722                         }
 723                 }
 724         }
 725
 726         set_tips $tips
 727
 728         update idletasks
 729         if {![info exists signals(form_dirty)]} {
 730                 log error "Freak out - signals(form_dirty) missing\n$w\n[tlc::stackdump]"
 731                 return
 732         }
 733         run_onchange_handlers
 734
 735         $signals(form_dirty) arm
 736         $signals(form_dirty) set_state 0
 737 }
 738
 739
 740 body tlc::Form::takefocus {} { #<<<1
 741         $dominos(need_rerender) force_if_pending
 742         if {[winfo exists $w.0,0,v]} {
 743                 focus $w.0,0,v
 744         }
 745 }
 746
 747
 748 body tlc::Form::need_rerender {} { #<<<1
 749         $dominos(need_rerender) tip
 750 }
 751
 752
 753 body tlc::Form::itemconfig {name args} { #<<<1
 754         set path        [path $name]
 755         $path configure {*}$args
 756 }
 757
 758
 759 body tlc::Form::path {name} { #<<<1
 760         $dominos(need_rerender) force_if_pending
 761
 762         if {[string is integer -strict $name]} {
 763                 if {[winfo exists $w.$name,0,v]} {
 764                         return $w.$name,0,v
 765                 } else {
 766                         error "No such item index: ($name)"
 767                 }
 768         } elseif {[regexp {[0-9]+,[0-9]+} $name]} {
 769                 lassign [split $name ,] r c
 770                 if {[winfo exists $w.$r,$c,v]} {
 771                         return $w.$r,$c,v
 772                 } else {
 773                         error "No such item index: ($name)"
 774                 }
 775         } else {
 776                 if {![info exists paths($name)]} {
 777                         error "No such form item: ($name), choose from (\"[join [array names paths] {", "}]\")"
 778                 }
 779                 return $paths($name)
 780         }
 781 }
 782
 783
 784 body tlc::Form::changed_dom_ref {} { #<<<1
 785         return $dominos(changed)
 786 }
 787
 788
 789 body tlc::Form::set_tips {args} { #<<<1
 790         if {[llength $args] == 1} {
 791                 # Support the variant syntax of one item packed with all the tips
 792                 # (for convenience)
 793                 set args        [lindex $args 0]
 794         }
 795         foreach {label tip} $args {
 796                 set widget      [path $label]
 797                 $w.tips attach $widget $tip
 798         }
 799         set tips        $args
 800 }
 801
 802
 803 body tlc::Form::mark_dirty {state} { #<<<1
 804         log debug
 805         $signals(form_dirty) set_state $state
 806 }
 807
 808
 809 body tlc::Form::path_by_var {varname} { #<<<1
 810         $dominos(need_rerender) force_if_pending
 811
 812         if {![info exists paths_by_var($varname)]} {
 813                 error "No such form item: ($varname)" "" \
 814                                 [list invalid_form_item $varname]
 815         }
 816         return $paths_by_var($varname)
 817 }
 818
 819 body tlc::Form::dat_changed {n1 n2 op} { #<<<1
 820         if {$op eq "w"} {
 821                 log debug "dat($n2) changed: ($dat($n2))"
 822         } elseif {$op eq "u"} {
 823                 log debug "dat($n2) unset"
 824         }
 825
 826         check_valid
 827
 828         if {[info exists dat($n2)]} {
 829                 if {[info exists expression_lists($n2)]} {
 830                         foreach exprname $expression_lists($n2) {
 831                                 $expressions($exprname) reassess
 832                         }
 833                 }
 834         }
 835
 836         $dominos(run_onchange_handlers) tip
 837
 838         set_textvariable [get_data]
 839
 840         if {[$signals(form_dirty) is_armed]} {
 841                 if {[info exists dat($n2)]} {
 842                         invoke_handlers onchange,$n2 $dat($n2)
 843                 }
 844                 invoke_handlers onchange [array get dat]
 845
 846                 $signals(form_dirty) set_state 1
 847         }
 848 }
 849
 850
 851 body tlc::Form::clear_data {} { #<<<1
 852         log debug $name
 853         $signals(form_dirty) disarm
 854         #array unset dat
 855         #array set dat {}
 856         # TODO: figure out why this is necessary
 857         foreach key [array names dat] {
 858                 set dat($key)   ""
 859         }
 860
 861         #array unset toggles
 862         #array set toggles {}
 863         #array unset expressions
 864         $signals(form_dirty) set_state 0
 865         $signals(form_dirty) arm
 866 }
 867
 868
 869 body tlc::Form::item_attach_signal {name signal {sense normal}} { #<<<1
 870         set path        [path $name]
 871         set varname     [varname_from_path $path]
 872         $toggles($varname) attach_signal $signal $sense
 873 }
 874
 875
 876 body tlc::Form::item_attach_expression {name expression} { #<<<1
 877         set path        [path $name]
 878         set varname     [varname_from_path $path]
 879         #array unset expressions $varname
 880         set exprname    "$varname[incr expr_seq]"
 881         tlc::Expression #auto expressions($exprname) -name "Form expression on $varname ($exprname)"
 882         lappend expression_lists($varname)      $exprname
 883         set expression  [string map [list \$value %<dat($varname)%>] $expression]
 884         $expressions($exprname) set_expression $expression
 885
 886         return $expressions($exprname)
 887 }
 888
 889
 890 body tlc::Form::varname_from_path {path} { #<<<1
 891         set ok  0
 892         foreach {v p} [array get paths_by_var] {
 893                 if {$p eq $path} {
 894                         set varname     $v
 895                         set ok  1
 896                         break
 897                 }
 898         }
 899
 900         if {$ok} {
 901                 return $varname
 902         } else {
 903                 error "No varname known for path: ($path)"
 904         }
 905 }
 906
 907
 908 body tlc::Form::arm_dirty {state} { #<<<1
 909         log debug
 910         if {$state} {
 911                 $signals(form_dirty) arm
 912         } else {
 913                 $signals(form_dirty) disarm
 914         }
 915 }
 916
 917
 918 body tlc::Form::valid_gate_ref {} { #<<<1
 919         log warning "valid_gate_ref deprecated, use \"signal_ref form_valid\" instead"
 920         return $signals(form_valid)
 921 }
 922
 923
 924 body tlc::Form::valid_condition {new_condition desc fields} { #<<<1
 925         tlc::Signal #auto valid_signals($new_condition) -name "valid_signals($new_condition)"
 926         lappend valid_conditions        [list $new_condition $desc $fields $valid_signals($new_condition)]
 927
 928         foreach field $fields {
 929                 $field_valid($field) attach_input $valid_signals($new_condition)
 930                 $valid_toggles($field) attach_output \
 931                                 [code $this valid_changed $new_condition $desc $fields]
 932         }
 933
 934         check_valid
 935
 936         $signals(form_valid) attach_input $valid_signals($new_condition)
 937 }
 938
 939
 940 body tlc::Form::valid_signal {signal desc fields} { #<<<1
 941         $dominos(need_rerender) force_if_pending
 942
 943         lappend valid_conditions        [list {} $desc $fields $signal]
 944
 945         foreach field $fields {
 946                 $field_valid($field) attach_input $signal
 947                 $valid_toggles($field) attach_output \
 948                                 [code $this valid_changed {} $desc $fields]
 949         }
 950
 951         $signals(form_valid) attach_input $signal
 952 }
 953
 954
 955 body tlc::Form::check_valid {} { #<<<1
 956         log debug
 957         foreach condition_desc $valid_conditions {
 958                 lassign $condition_desc condition desc fields signal
 959                 if {$condition ne {}} {
 960                         tlc::try {
 961                                 $signal set_state [expr $condition]
 962                         } onerr {
 963                                 default {
 964                                         log error "Error in valid check \"$condition\", desc: \"$desc\": $errmsg"
 965                                 }
 966                         }
 967                 }
 968         }
 969 }
 970
 971
 972 body tlc::Form::clear_valid_conditions {} { #<<<1
 973         set valid_conditions    {}
 974         check_valid
 975 }
 976
 977
 978
 979 body tlc::Form::valid_changed {condition desc fields newstate} { #<<<1
 980         $dominos(need_valid_desc_update) tip
 981 }
 982
 983
 984 body tlc::Form::update_valid_desc {} { #<<<1
 985         array set new_desc      {}
 986
 987         foreach condition_desc $valid_conditions {
 988                 lassign $condition_desc condition desc fields signal
 989                 foreach field $fields {
 990                         if {![$valid_toggles($field) state]} {
 991                                 lappend new_desc($field)        $desc
 992                         }
 993                 }
 994         }
 995
 996         set obsolete    [lindex [tlc::intersect3 [array names paths_by_var] [array names new_desc]] 0]
 997         foreach field $obsolete {
 998                 $w.valid_tips detach [$valid_toggles($field) target]
 999         }
1000         foreach {field desclist} [array get new_desc] {
1001                 $w.valid_tips attach [$valid_toggles($field) target] [join $desclist \n]
1002         }
1003 }
1004
1005
1006 body tlc::Form::force_form_valid_update {} { #<<<1
1007         form_valid_reasons_changed
1008 }
1009
1010
1011 body tlc::Form::enabled_changed {newstate} { #<<<1
1012         if {!($newstate)} {
1013                 $w.valid_tips popdown
1014         }
1015 }
1016
1017
1018 body tlc::Form::form_valid_reasons_changed {} { #<<<1
1019         set newstate    [$signals(form_valid) state]
1020         if {$newstate} {
1021                 invoke_handlers valid_status_changed $newstate {}
1022         } else {
1023                 if {[$signals(enabled) state]} {
1024                         set reasons     {}
1025                         foreach condition_desc $valid_conditions {
1026                                 lassign $condition_desc condition desc fields signal
1027                                 if {![$signal state]} {
1028                                         lappend reasons $desc
1029                                 }
1030                         }
1031                         invoke_handlers valid_status_changed $newstate $reasons
1032                 } else {
1033                         invoke_handlers valid_status_changed $newstate "Form disabled"
1034                 }
1035         }
1036 }
1037
1038
1039 body tlc::Form::textvariable_changed {newvalue} { #<<<1
1040         log debug "$name newvalue: ($newvalue)"
1041         array set tmp   $newvalue
1042         set existing    [array names dat]
1043         set new                 [array names tmp]
1044         array unset tmp
1045
1046         set removed_keys        [lindex [tlc::intersect3 $existing $new] 2]
1047         foreach key $removed_keys {
1048                 set dat($key)   ""
1049         }
1050
1051         set_data $newvalue
1052 }
1053
1054
1055 body tlc::Form::default_options {type args} { #<<<1
1056         set type        [canonize_type $type]
1057
1058         set default_options($type)      $args
1059 }
1060
1061
1062 body tlc::Form::canonize_type {type} { #<<<1
1063         switch -- $type {
1064                 ""                      -
1065                 entry           {return "entry"}
1066                 checkbox        -
1067                 checkbutton     {return "checkbutton"}
1068                 label           {return "label"}
1069                 vartextbox      -
1070                 textbox         -
1071                 text            {return "text"}
1072                 button          {return "button"}
1073                 combobox        {return "combobox"}
1074                 mycombobox      {return "mycombobox"}
1075                 date            -
1076                 dateentry       {return "dateentry"}
1077                 calendar        {return "calendar"}
1078                 fileselect      {return "fileselect"}
1079                 list            {return "list"}
1080                 lookup          {return "lookup"}
1081                 spinint         {return "spinint"}
1082                 spinner         {return "spinner"}
1083                 message         {return "message"}
1084                 intentry        {return "intentry"}
1085                 tagentry        {return "tagentry"}
1086                 radiogroup      {return "radiogroup"}
1087                 checkgroup      {return "checkgroup"}
1088                 subform         -
1089                 form            {return "subform"}
1090                 tablelist       {return "tablelist"}
1091
1092                 default {
1093                         if {[info exists tlc::Form::custom_types($type)]} {
1094                                 return $type
1095                         } else {
1096                                 error "Unknown type: ($type)"
1097                         }
1098                 }
1099         }
1100 }
1101
1102
1103 body tlc::Form::cleanup {} { #<<<1
1104         #log warning "$w:[tlc::stackdump]"
1105         array unset toggles
1106         array unset valid_toggles
1107         array unset signals
1108         array unset dominos
1109 }
1110
1111
1112 body tlc::Form::widget_destroyed {} { #<<<1
1113         #log warning $w
1114         cleanup
1115         #log warning "$w done"
1116 }
1117
1118
1119 body tlc::Form::run_onchange_handlers {} { #<<<1
1120         log debug
1121         set before      [array get dat]
1122
1123         set changed_fields      {}
1124         set tmp [tlc::intersect3 [dict keys $old] [dict keys $before]]
1125         foreach key [lindex $tmp 0] {
1126                 dict set changed_fields $key    "removed"
1127         }
1128         foreach key [lindex $tmp 1] {
1129                 if {[dict get $old $key] ne [dict get $before $key]} {
1130                         dict set changed_fields $key    "changed"
1131                 }
1132         }
1133         foreach key [lindex $tmp 2] {
1134                 dict set changed_fields $key    "added"
1135         }
1136
1137         tlc::try {
1138                 set slave       [interp create -safe]
1139
1140                 $slave alias element apply {
1141                         {form label op args} {
1142                                 return [[$form path $label] $op {*}$args]
1143                         }
1144                 } $this
1145
1146                 #$slave alias log [code $this log]      ;# is this safe?
1147                 $slave alias log apply {
1148                         {lvl msg} {
1149                                 puts stderr $msg
1150                         }
1151                 }
1152
1153                 $slave eval [list array set dat                 [array get dat]]
1154                 $slave eval [list set old                               $old]
1155                 $slave eval [list set new                               $before]
1156                 $slave eval [list set changed_fields    $changed_fields]
1157
1158                 foreach handler $onchange_handlers {
1159                         $slave eval [list apply {
1160                                 {code} {
1161                                         if {[catch {uplevel #0 $code} errmsg options]} {
1162                                                 log error "Error in _onchange handler: $errmsg\n$::errorInfo"
1163                                         }
1164                                 }
1165                         } $handler]
1166                 }
1167
1168                 set after       [$slave eval {array get dat}]
1169         } onerr {
1170                 default {STDMSG}
1171         }
1172
1173         if {[info exists slave]} {
1174                 interp delete $slave
1175         }
1176
1177         if {[info exists after]} {
1178                 set changeset   {}
1179                 dict for {k v} $after {
1180                         log debug "Checking ($k) ($v), existed before? ([dict exists $before $k])"
1181                         if {
1182                                 ![dict exists $before $k] ||
1183                                 [dict get $before $k] ne [dict get $after $k]
1184                         } {
1185                                 dict set changeset $k $v
1186                         }
1187                 }
1188
1189                 if {[llength $changeset] > 0} {
1190                         log debug "Applying changes to dat():"
1191                         array set chgset        $changeset
1192                         parray debug chgset
1193                         $dominos(run_onchange_handlers) lock
1194                         arm_dirty 0
1195                         array set dat   $changeset
1196                         arm_dirty 1
1197                         $dominos(run_onchange_handlers) unlock
1198                         check_valid
1199                 }
1200         }
1201
1202         set old [array get dat]
1203 }
1204
1205