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
  83                 method rerender {}
  84                 method need_rerender {}
  85                 method dat_changed {n1 n2 op}
  86                 method clear_valid_conditions {}
  87                 method check_valid {}
  88                 method valid_changed {condition desc fields newstate}
  89                 method update_valid_desc {}
  90                 method enabled_changed {newstate}
  91                 method form_valid_reasons_changed {}
  92                 method canonize_type {type}
  93                 method cleanup {}
  94         }
  95 }
  96
  97
  98 configbody tlc::Form::schema { #<<<1
  99         set tips        {}
 100         set schema      [tlc::decomment $schema]
 101         need_rerender
 102 }
 103
 104
 105 configbody tlc::Form::state { #<<<1
 106         log debug "state: ($state)"
 107         [stategate_ref] configure -default [expr {$state == "normal"}]
 108 }
 109
 110
 111 configbody tlc::Form::tooltipdelay { #<<<1
 112         $w.tips configure -delay $itk_option(-tooltipdelay)
 113 }
 114
 115
 116 configbody tlc::Form::tooltiptimeout { #<<<1
 117         $w.tips configure -showtime $itk_option(-tooltiptimeout)
 118 }
 119
 120
 121 body tlc::Form::constructor {args} { #<<<1
 122         array set paths {}
 123         array set paths_by_var {}
 124         array set toggles {}
 125         array set valid_toggles {}
 126         array set expressions {}
 127         array set expression_lists {}
 128         array set valid_signals {}
 129         array set field_valid {}
 130         array set dominos {}
 131         array set default_options {}
 132
 133         tlc::Domino #auto dominos(need_rerender) -name "$w need_rerender"
 134         tlc::Domino #auto dominos(need_valid_desc_update) \
 135                         -name "$w need_valid_desc_update"
 136         tlc::Varwatch #auto signals(form_dirty) -name "$w form_dirty"
 137         tlc::Vardomino #auto dominos(changed) -name "$w changed" \
 138                         -textvariable [scope dat]
 139         $signals(form_dirty) attach_dirtyvar [scope dat]
 140         $signals(form_dirty) register_handler onchange_info [code $this dat_changed]
 141         tlc::Hoverbox $w.tips
 142         tlc::Hoverbox $w.valid_tips
 143         tlc::Gate #auto signals(enabled) -name "$w enabled" \
 144                         -mode "and" -default 1
 145         tlc::Gate #auto signals(form_valid) -name "$w form_valid" \
 146                         -mode "and" -default 1
 147         tlc::Domino #auto dominos(reasons_changed) -name "$w reasons_changed"
 148
 149         $signals(enabled) attach_input [stategate_ref]
 150         $signals(enabled) attach_output [code $this enabled_changed]
 151
 152         $dominos(reasons_changed) attach_output \
 153                         [code $this form_valid_reasons_changed]
 154         $signals(enabled) attach_output [list $dominos(reasons_changed) tip]
 155
 156         $dominos(need_rerender) attach_output [code $this rerender]
 157         $dominos(need_valid_desc_update) attach_output \
 158                         [code $this update_valid_desc]
 159
 160         eval itk_initialize $args
 161
 162         if {$name == ""} {
 163                 set name        $w
 164         } else {
 165                 log debug "Setting name ($name) for $w"
 166         }
 167 }
 168
 169
 170 body tlc::Form::destructor {} { #<<<1
 171         log debug $name
 172
 173         # Thse reference widgets that may not exist anymore (if we are here
 174         # because of destroy rather than delete object, for instance), and
 175         # the standard cleanup will have them change state, and hence try to
 176         # configure their widgets.  Doing this causes them to die before their
 177         # inputs, which stops them trying to update their outputs
 178         cleanup
 179         #foreach child [winfo children $w] {
 180         #       if {[itcl::is object -class tlc::Form $child]} {
 181         #               log debug "Pre-emptively deleting subform $child"
 182         #               delete object $child
 183         #       }
 184         #}
 185 }
 186
 187
 188 body tlc::Form::set_data {args} { #<<<1
 189         if {[llength $args] == 1} {
 190                 set data        [lindex $args 0]
 191         } else {
 192                 set data        $args
 193         }
 194         if {[llength $data] % 2 != 0} {
 195                 log error "Badly formatted data, must be a list of key value pairs"
 196                 error "Badly formatted data, must be a list of key value pairs" "" \
 197                                 [list data_format_error]
 198         }
 199
 200         $signals(form_dirty) disarm
 201         array set dat $data
 202
 203         check_valid
 204         foreach {varname exprs} [array get expression_lists] {
 205                 foreach exprname $exprs {
 206                         $expressions($exprname) reassess
 207                 }
 208         }
 209
 210         $signals(form_dirty) arm
 211         if {[$signals(form_dirty) is_armed]} {
 212                 $signals(form_dirty) set_state 0
 213         }
 214 }
 215
 216
 217 body tlc::Form::set_key {args} { #<<<1
 218         log debug $name
 219         switch -- [llength $args] {
 220                 0 {error "No key specified" "" [list syntax_error no_key_specified]}
 221                 1 {error "No value specified" "" [list syntax_error no_value_specified]}
 222                 2 {
 223                         set key [lindex $args 0]
 224                         set val [lindex $args 1]
 225                         return [set_data $key $val]
 226                 }
 227         }
 228
 229         set key         [lindex $args 0]
 230         set keys        [lrange $args 1 end-1]
 231         set val         [lindex $args end]
 232         set handler     [path_by_var $key]
 233         if {[itcl::is object $handler] && [$handler isa tlc::Form]} {
 234                 eval [list $handler set_key] $keys [list $val]
 235                 set dat($key)   [$handler get_data]
 236         } else {
 237                 # TODO: recursive setter that composes the nested array list on unwind
 238                 error "Only subforms are currently supported for deep key sets" "" \
 239                                 [list not_implemented]
 240         }
 241 }
 242
 243
 244 body tlc::Form::get_data {args} { #<<<1
 245         $dominos(need_rerender) force_if_pending
 246
 247         if {[llength $args] == 0} {
 248                 return [array get dat]
 249         } elseif {[llength $args] == 1} {
 250                 set key         [lindex $args 0]
 251                 if {![info exists dat($key)]} {
 252                         error "Bad key: \"$key\", should be one of [join [array names tmp] {, }]" "" \
 253                                         [list bad_key [list $key]]
 254                 }
 255                 return $dat($key)
 256         } else {
 257                 set last        [array get dat]
 258                 set so_far      {}
 259                 foreach key $args {
 260                         array unset tmp
 261                         tlc::try {
 262                                 array set tmp   $last
 263                         } onerr {
 264                                 default {
 265                                         error "Cannot build array from key level [llength $so_far] \"[join $so_far ->]\": $errmsg" "" \
 266                                                         [list format_error $so_far]
 267                                 }
 268                         }
 269                         lappend so_far  $key
 270                         if {![info exists tmp($key)]} {
 271                                 error "Bad key: \"[join $so_far ->]\", should be one of [join [array names tmp] {, }]" "" \
 272                                                 [list bad_key $so_far]
 273                         }
 274                         set last        $tmp($key)
 275                 }
 276                 return $last
 277         }
 278 }
 279
 280
 281 body tlc::Form::dirty_gate_ref {} { #<<<1
 282         log warning "dirty_gate_ref deprecated, use \"signal_ref form_dirty\" instead"
 283         return $signals(form_dirty)
 284 }
 285
 286
 287 body tlc::Form::rerender {} { #<<<1
 288         if {$schema == $oldschema} return
 289         log debug $name
 290
 291         set_data        {}
 292         $signals(form_dirty) disarm
 293         catch {eval destroy [lindex [tlc::intersect3 [winfo children $w] [list $w.tips $w.valid_tips]] 0]}
 294
 295         # Layout context init
 296         array set layout {
 297                 label_col_args_sticky           {}
 298                 label_cell_args_sticky          {-anchor ne}
 299                 label_widget_args_sticky        {}
 300                 cell_args_sticky                        {-anchor nw}
 301                 col_args_sticky                         {}
 302         }
 303         set layout(row_args_sticky)             [list -pady $itk_option(-padding)]
 304
 305         catch {unset paths}; array set paths {}
 306         catch {unset paths_by_var}; array set paths_by_var {}
 307         catch {unset toggles}; array set toggles {}
 308         catch {unset valid_toggles}; array set valid_toggles {}
 309         catch {unset field_valid}; array set field_valid {}
 310         catch {unset valid_signals}; array set valid_signals {}
 311         catch {unset expressions}
 312         catch {unset expression_lists}
 313         clear_valid_conditions
 314         set formvars    {}
 315         set row         0
 316         set col         0
 317         set reset       1
 318         foreach {label info} $schema {
 319                 set varname             ""
 320                 set type                ""
 321                 set arglist             ""
 322
 323                 if {$reset} {
 324                         set layout(label_cell_args)             $layout(label_cell_args_sticky)
 325                         set layout(label_col_args)              $layout(label_col_args_sticky)
 326                         set layout(label_widget_args)   $layout(label_widget_args_sticky)
 327                         set layout(cell_args)                   $layout(cell_args_sticky)
 328                         set layout(row_args)                    $layout(row_args_sticky)
 329                         set layout(col_args)                    $layout(col_args_sticky)
 330                 }
 331
 332                 if {[string index $label 0] == "_"} {
 333                         switch -- $label {
 334                                 _layout         { #<<<
 335                                         if {$label == "_layout"} {
 336                                                 switch -- [lindex $info 0] {
 337                                                         cell_args_sticky                        -
 338                                                         row_args_sticky                         -
 339                                                         col_args_sticky                         -
 340                                                         label_cell_args_sticky          -
 341                                                         label_widget_args_sticky        -
 342                                                         label_col_args_sticky           {
 343                                                                 set layout([lindex $info 0])    [lrange $info 1 end]
 344                                                                 set layout([string range [lindex $info 0] 0 end-7]) \
 345                                                                                 [lrange $info 1 end]
 346                                                         }
 347                                                         label_args_sticky {
 348                                                                 log warning "_layout label_args_sticky is deprecated - use label_cell_args_sticky"
 349                                                                 set layout(label_cell_args_sticky)      [lrange $info 1 end]
 350                                                                 set layout(label_cell_args) \
 351                                                                                 [lrange $info 1 end]
 352                                                         }
 353
 354                                                         cell_args                       -
 355                                                         row_args                        -
 356                                                         col_args                        -
 357                                                         label_col_args          -
 358                                                         label_widget_args       -
 359                                                         label_cell_args {
 360                                                                 set layout([lindex $info 0])    [lrange $info 1 end]
 361                                                                 set reset       0
 362                                                         }
 363                                                         label_args      {
 364                                                                 log warning "_layout label_args is deprecated - use label_cell_args"
 365                                                                 set layout(label_cell_args)             [lrange $info 1 end]
 366                                                                 set reset       0
 367                                                         }
 368
 369                                                         next_row                        -
 370                                                         next_col                        -
 371                                                         next_column                     {
 372                                                                 switch -- [string index $itk_option(-winding) 0] {
 373                                                                         "h" {
 374                                                                                 incr row        1
 375                                                                                 set col         0
 376                                                                                 set layout(row_args)    $layout(row_args_sticky)
 377                                                                         }
 378
 379                                                                         default -
 380                                                                         "v" {
 381                                                                                 incr col        2
 382                                                                                 set row         0
 383                                                                                 set layout(col_args)    $layout(col_args_sticky)
 384                                                                         }
 385                                                                 }
 386                                                         }
 387
 388                                                         skip_cols                       -
 389                                                         skip_columns            -
 390                                                         skip_rows                       -
 391                                                         skip_col                        -
 392                                                         skip_column                     -
 393                                                         skip_row                        {
 394                                                                 switch -- [string index $itk_option(-winding) 0] {
 395                                                                         "h" {
 396                                                                                 set amnt        [lindex $info 1]
 397                                                                                 if {$amnt == ""} {set amnt      1}
 398                                                                                 incr col        $amnt
 399                                                                                 incr col        $amnt
 400                                                                         }
 401
 402                                                                         default -
 403                                                                         "v" {
 404                                                                                 set amnt        [lindex $info 1]
 405                                                                                 if {$amnt == ""} {set amnt      1}
 406                                                                                 incr row        $amnt
 407                                                                         }
 408                                                                 }
 409                                                         }
 410
 411                                                         default_options         {
 412                                                                 log warning "default_options mode of _layout is deprecated.  Use top level directive _default_options instead"
 413                                                                 set type        [canonize_type [lindex $info 1]]
 414                                                                 set default_options($type)      [lrange $info 2 end]
 415                                                         }
 416
 417                                                         default {
 418                                                                 error "Unrecognised layout parameter: ([lindex $info 0])"
 419                                                         }
 420                                                 }
 421                                         }
 422                                         #>>>
 423                                 }
 424                                 _validation - _validation_not_blank { #<<<
 425                                         if {$label == "_validation"} {
 426                                                 valid_condition [lindex $info 0] [lindex $info 1] [lindex $info 2]
 427                                         }
 428                                         if {$label == "_validation_not_blank"} {
 429                                                 set template    [lindex $info 0]
 430                                                 foreach {labelname varname} [lrange $info 1 end] {
 431                                                         set condition   "\[string trim \$dat([string map {{ } {\ } {)} {\)}} $varname])\] != {}"
 432                                                         valid_condition \
 433                                                                         $condition \
 434                                                                         [string map [list %1 $labelname] $template] \
 435                                                                         [list $varname]
 436                                                 }
 437                                         }
 438                                         #>>>
 439                                 }
 440                                 _tips - _tooltips { #<<<
 441                                         set_tips $info
 442                                         #>>>
 443                                 }
 444                                 _defaults { #<<<
 445                                         array set dat   $info
 446                                         #>>>
 447                                 }
 448                                 _default_options { #<<<
 449                                         set type        [canonize_type [lindex $info 0]]
 450                                         set default_options($type)      [lrange $info 1 end]
 451                                         #>>>
 452                                 }
 453                                 default {
 454                                         error "Invalid meta directive \"$label\", must be one of _layout, _validation, _validation_not_blank, _tips or _tooltips" "" [list invalid_meta_directive $label]
 455                                 }
 456                         }
 457
 458                         continue
 459                 }
 460
 461                 set reset       1
 462
 463                 foreach {varname type} $info break
 464                 lappend formvars        $varname
 465                 set type                        [canonize_type $type]
 466
 467                 if {[info exists default_options($type)]} {
 468                         set arglist     [concat $default_options($type) [lrange $info 2 end]]
 469                 } else {
 470                         set arglist     [lrange $info 2 end]
 471                 }
 472
 473                 if {[string index $label 0] == " "} {
 474                         label $w.$row,$col,l -text "" -width 0 -highlightthickness 0 \
 475                                         -background $itk_option(-background)
 476                 } else {
 477                         label $w.$row,$col,l -text $label \
 478                                         -background $itk_option(-background)
 479                 }
 480                 if {[llength $layout(label_widget_args)] > 0} {
 481                         eval [list $w.$row,$col,l configure] $layout(label_widget_args)
 482                 }
 483
 484                 if {![info exists dat($varname)]} {
 485                         set dat($varname)       ""
 486                 }
 487                 if {[string first " " $varname] != -1} {
 488                         # Itcl bug (still as of 3.3) prevents scope / resolver working
 489                         # with arrays whose keys contain spaces.  We craft our own here
 490                         # that works with the resolver
 491
 492                         # Works, but ugly
 493                         #set scoped_varname     "[list @itcl $this] [namespace current]::dat($varname)"
 494                         set tmp         [scope dat($varname)]
 495                         set scoped_varname      [concat [lrange $tmp 0 1] [lindex $tmp 2]]
 496                 } else {
 497                         set scoped_varname      [scope dat($varname)]
 498                 }
 499
 500                 tlc::Gate #auto field_valid($varname) -name "$w field_valid $varname" \
 501                                 -mode "and" -default 1
 502                 tlc::StateToggle #auto valid_toggles($varname) \
 503                                         -mode "or" -default 1 \
 504                                 $w.$row,$col,l \
 505                                         -foreground {red black}
 506                 $valid_toggles($varname) attach_signal $signals(enabled) inverted
 507                 $valid_toggles($varname) attach_signal $field_valid($varname)
 508
 509                 $valid_toggles($varname) attach_output \
 510                                 [list $dominos(reasons_changed) tip]
 511
 512                 set toggle                      {-state {disabled normal}}
 513                 switch -- $type {
 514                         entry {
 515                                 entry $w.$row,$col,v -textvariable $scoped_varname
 516                         }
 517
 518                         checkbutton {
 519                                 checkbutton $w.$row,$col,v -variable $scoped_varname
 520                         }
 521
 522                         label {
 523                                 label $w.$row,$col,v -textvariable $scoped_varname \
 524                                                 -justify left \
 525                                                 -font [$tlc::theme setting boldfont]
 526                         }
 527
 528                         text {
 529                                 tlc::vartextbox $w.$row,$col,v -textvariable $scoped_varname
 530                         }
 531
 532                         button {
 533                                 button $w.$row,$col,v
 534                         }
 535
 536                         combobox {
 537                                 tlc::mycombobox $w.$row,$col,v -textvariable $scoped_varname
 538                         }
 539
 540                         dateentry {
 541                                 tlc::Dateentry $w.$row,$col,v -textvariable $scoped_varname
 542                         }
 543
 544                         calendar {
 545                                 tlc::Calendar $w.$row,$col,v -command [code set dat($varname)]
 546                         }
 547
 548                         fileselect {
 549                                 tlc::Fileselectbox $w.$row,$col,v -textvariable $scoped_varname
 550                         }
 551
 552                         list {
 553                                 tlc::Browse_treeview_list $w.$row,$col,v \
 554                                                 -textvariable $scoped_varname \
 555                                                 -width 300 -height 110
 556                         }
 557
 558                         lookup {
 559                                 tlc::Lookup $w.$row,$col,v -textvariable $scoped_varname
 560                         }
 561
 562                         spinint {
 563                                 tlc::Spinint $w.$row,$col,v -textvariable $scoped_varname
 564                         }
 565
 566                         spinner {
 567                                 tlc::Spinner $w.$row,$col,v -textvariable $scoped_varname
 568                                 # TODO: wire valid_signal?
 569                         }
 570
 571                         message {
 572                                 message $w.$row,$col,v \
 573                                                 -textvariable $scoped_varname \
 574                                                 -font [$tlc::theme setting boldfont]
 575                                 set toggle      {}
 576                         }
 577
 578                         intentry {
 579                                 entry $w.$row,$col,v -textvariable $scoped_varname \
 580                                                 -validate all \
 581                                                 -validatecommand {string is integer {%P}}
 582                         }
 583
 584                         tagentry {
 585                                 Tagentry $w.$row,$col,v -textvariable $scoped_varname
 586                         }
 587
 588                         radiogroup {
 589                                 tlc::Radiogroup $w.$row,$col,v -textvariable $scoped_varname
 590                         }
 591
 592                         checkgroup {
 593                                 tlc::Checkgroup $w.$row,$col,v -textvariable $scoped_varname
 594                         }
 595
 596                         subform {
 597                                 tlc::Form $w.$row,$col,v -textvariable $scoped_varname \
 598                                                 -name "$name -> $varname"
 599                                 valid_signal [$w.$row,$col,v signal_ref form_valid] "" $varname
 600                         }
 601
 602                         tablelist {
 603                                 tlc::Tablelist $w.$row,$col,v -textvariable $scoped_varname
 604                                 # TODO: wire valid_signal?
 605                         }
 606
 607                         default {
 608                                 if {[info exists tlc::Form::custom_types($type)]} {
 609                                         $tlc::Form::custom_types($type) $w.$row,$col,v \
 610                                                         -textvariable $scoped_varname
 611                                 } else {
 612                                         log error "Unknown type: ($type)"
 613                                         continue
 614                                 }
 615                         }
 616                 }
 617                 set paths($label)                       $w.$row,$col,v
 618                 set paths_by_var($varname)      $w.$row,$col,v
 619                 eval [list tlc::StateToggle #auto toggles($varname) $w.$row,$col,v] \
 620                                 $toggle
 621                 $toggles($varname) attach_signal $signals(enabled)
 622
 623                 if {[llength $arglist] != 0} {
 624                         eval [list $w.$row,$col,v configure] $arglist
 625                 }
 626
 627                 set dc          [expr {$col+1}]
 628                 eval [list blt::table $w $w.$row,$col,l $row,$col] \
 629                                 $layout(label_cell_args)
 630                 blt::table configure $w c$col -resize none
 631                 eval [list blt::table $w $w.$row,$col,v $row,$dc] $layout(cell_args)
 632                 eval [list blt::table configure $w c$col] $layout(label_col_args)
 633                 eval [list blt::table configure $w c$dc] $layout(col_args)
 634                 eval [list blt::table configure $w r$row] $layout(row_args)
 635
 636                 switch -- [string index $itk_option(-winding) 0] {
 637                         "h" {
 638                                 incr col 2
 639                         }
 640
 641                         default -
 642                         "v" {
 643                                 incr row
 644                         }
 645                 }
 646         }
 647
 648         set_tips $tips
 649
 650         update idletasks
 651         if {![info exists signals(form_dirty)]} {
 652                 log error "Freak out - signals(form_dirty) missing\n$w\n[tlc::stackdump]"
 653                 return
 654         }
 655         $signals(form_dirty) arm
 656         $signals(form_dirty) set_state 0
 657 }
 658
 659
 660 body tlc::Form::takefocus {} { #<<<1
 661         $dominos(need_rerender) force_if_pending
 662         focus $w.0,0,v
 663 }
 664
 665
 666 body tlc::Form::need_rerender {} { #<<<1
 667         $dominos(need_rerender) tip
 668 }
 669
 670
 671 body tlc::Form::itemconfig {name args} { #<<<1
 672         set path        [path $name]
 673         eval [list $path configure] $args
 674 }
 675
 676
 677 body tlc::Form::path {name} { #<<<1
 678         $dominos(need_rerender) force_if_pending
 679
 680         if {[string is integer -strict $name]} {
 681                 if {[winfo exists $w.$name,0,v]} {
 682                         return $w.$name,0,v
 683                 } else {
 684                         error "No such item index: ($name)"
 685                 }
 686         } elseif {[regexp {[0-9]+,[0-9]+} $name]} {
 687                 foreach {r c} [split $name ,] break
 688                 if {[winfo exists $w.$r,$c,v]} {
 689                         return $w.$r,$c,v
 690                 } else {
 691                         error "No such item index: ($name)"
 692                 }
 693         } else {
 694                 if {![info exists paths($name)]} {
 695                         error "No such form item: ($name), choose from (\"[join [array names paths] {", "}]\")"
 696                 }
 697                 return $paths($name)
 698         }
 699 }
 700
 701
 702 body tlc::Form::changed_dom_ref {} { #<<<1
 703         return $dominos(changed)
 704 }
 705
 706
 707 body tlc::Form::set_tips {args} { #<<<1
 708         if {[llength $args] == 1} {
 709                 # Support the variant syntax of one item packed with all the tips
 710                 # (for convenience)
 711                 set args        [lindex $args 0]
 712         }
 713         foreach {label tip} $args {
 714                 set widget      [path $label]
 715                 $w.tips attach $widget $tip
 716         }
 717         set tips        $args
 718 }
 719
 720
 721 body tlc::Form::mark_dirty {state} { #<<<1
 722         log debug
 723         $signals(form_dirty) set_state $state
 724 }
 725
 726
 727 body tlc::Form::path_by_var {varname} { #<<<1
 728         $dominos(need_rerender) force_if_pending
 729
 730         if {![info exists paths_by_var($varname)]} {
 731                 error "No such form item: ($varname)" "" \
 732                                 [list invalid_form_item $varname]
 733         }
 734         return $paths_by_var($varname)
 735 }
 736
 737 body tlc::Form::dat_changed {n1 n2 op} { #<<<1
 738         if {$op == "w"} {
 739                 log debug "dat($n2) changed: ($dat($n2))"
 740         } elseif {$op == "u"} {
 741                 log debug "dat($n2) unset"
 742         }
 743         set_textvariable [get_data]
 744
 745         if {[$signals(form_dirty) is_armed]} {
 746                 check_valid
 747                 if {[info exists dat($n2)]} {
 748                         if {[info exists expression_lists($n2)]} {
 749                                 foreach exprname $expression_lists($n2) {
 750                                         $expressions($exprname) reassess
 751                                 }
 752                         }
 753                         invoke_handlers onchange,$n2 $dat($n2)
 754                 }
 755                 invoke_handlers onchange [array get dat]
 756
 757                 $signals(form_dirty) set_state 1
 758         }
 759 }
 760
 761
 762 body tlc::Form::clear_data {} { #<<<1
 763         log debug $name
 764         $signals(form_dirty) disarm
 765         #array unset dat
 766         #array set dat {}
 767         # TODO: figure out why this is necessary
 768         foreach key [array names dat] {
 769                 set dat($key)   ""
 770         }
 771
 772         #array unset toggles
 773         #array set toggles {}
 774         #array unset expressions
 775         $signals(form_dirty) set_state 0
 776         $signals(form_dirty) arm
 777 }
 778
 779
 780 body tlc::Form::item_attach_signal {name signal {sense normal}} { #<<<1
 781         set path        [path $name]
 782         set varname     [varname_from_path $path]
 783         $toggles($varname) attach_signal $signal $sense
 784 }
 785
 786
 787 body tlc::Form::item_attach_expression {name expression} { #<<<1
 788         set path        [path $name]
 789         set varname     [varname_from_path $path]
 790         #array unset expressions $varname
 791         set exprname    "$varname[incr expr_seq]"
 792         tlc::Expression #auto expressions($exprname) -name "Form expression on $varname ($exprname)"
 793         lappend expression_lists($varname)      $exprname
 794         set expression  [string map [list \$value %<dat($varname)%>] $expression]
 795         $expressions($exprname) set_expression $expression
 796
 797         return $expressions($exprname)
 798 }
 799
 800
 801 body tlc::Form::varname_from_path {path} { #<<<1
 802         set ok  0
 803         foreach {v p} [array get paths_by_var] {
 804                 if {$p == $path} {
 805                         set varname     $v
 806                         set ok  1
 807                         break
 808                 }
 809         }
 810
 811         if {$ok} {
 812                 return $varname
 813         } else {
 814                 error "No varname known for path: ($path)"
 815         }
 816 }
 817
 818
 819 body tlc::Form::arm_dirty {state} { #<<<1
 820         log debug
 821         if {$state} {
 822                 $signals(form_dirty) arm
 823         } else {
 824                 $signals(form_dirty) disarm
 825         }
 826 }
 827
 828
 829 body tlc::Form::valid_gate_ref {} { #<<<1
 830         log warning "valid_gate_ref deprecated, use \"signal_ref form_valid\" instead"
 831         return $signals(form_valid)
 832 }
 833
 834
 835 body tlc::Form::valid_condition {new_condition desc fields} { #<<<1
 836         tlc::Signal #auto valid_signals($new_condition) -name "valid_signals($new_condition)"
 837         lappend valid_conditions        [list $new_condition $desc $fields $valid_signals($new_condition)]
 838
 839         foreach field $fields {
 840                 $field_valid($field) attach_input $valid_signals($new_condition)
 841                 $valid_toggles($field) attach_output \
 842                                 [code $this valid_changed $new_condition $desc $fields]
 843         }
 844
 845         check_valid
 846
 847         $signals(form_valid) attach_input $valid_signals($new_condition)
 848 }
 849
 850
 851 body tlc::Form::valid_signal {signal desc fields} { #<<<1
 852         $dominos(need_rerender) force_if_pending
 853
 854         lappend valid_conditions        [list {} $desc $fields $signal]
 855
 856         foreach field $fields {
 857                 $field_valid($field) attach_input $signal
 858                 $valid_toggles($field) attach_output \
 859                                 [code $this valid_changed {} $desc $fields]
 860         }
 861
 862         $signals(form_valid) attach_input $signal
 863 }
 864
 865
 866 body tlc::Form::check_valid {} { #<<<1
 867         foreach condition_desc $valid_conditions {
 868                 foreach {condition desc fields signal} $condition_desc break
 869                 if {$condition != {}} {
 870                         $signal set_state [expr $condition]
 871                 }
 872         }
 873 }
 874
 875
 876 body tlc::Form::clear_valid_conditions {} { #<<<1
 877         set valid_conditions    {}
 878         check_valid
 879 }
 880
 881
 882
 883 body tlc::Form::valid_changed {condition desc fields newstate} { #<<<1
 884         $dominos(need_valid_desc_update) tip
 885 }
 886
 887
 888 body tlc::Form::update_valid_desc {} { #<<<1
 889         array set new_desc      {}
 890
 891         foreach condition_desc $valid_conditions {
 892                 foreach {condition desc fields signal} $condition_desc break
 893                 foreach field $fields {
 894                         if {![$valid_toggles($field) state]} {
 895                                 lappend new_desc($field)        $desc
 896                         }
 897                 }
 898         }
 899
 900         set obsolete    [lindex [tlc::intersect3 [array names paths_by_var] [array names new_desc]] 0]
 901         foreach field $obsolete {
 902                 $w.valid_tips detach [$valid_toggles($field) target]
 903         }
 904         foreach {field desclist} [array get new_desc] {
 905                 $w.valid_tips attach [$valid_toggles($field) target] [join $desclist \n]
 906         }
 907 }
 908
 909
 910 body tlc::Form::force_form_valid_update {} { #<<<1
 911         form_valid_reasons_changed
 912 }
 913
 914
 915 body tlc::Form::enabled_changed {newstate} { #<<<1
 916         if {!($newstate)} {
 917                 $w.valid_tips popdown
 918         }
 919 }
 920
 921
 922 body tlc::Form::form_valid_reasons_changed {} { #<<<1
 923         set newstate    [$signals(form_valid) state]
 924         if {$newstate} {
 925                 invoke_handlers valid_status_changed $newstate {}
 926         } else {
 927                 if {[$signals(enabled) state]} {
 928                         set reasons     {}
 929                         foreach condition_desc $valid_conditions {
 930                                 foreach {condition desc fields signal} $condition_desc break
 931                                 if {![$signal state]} {
 932                                         lappend reasons $desc
 933                                 }
 934                         }
 935                         invoke_handlers valid_status_changed $newstate $reasons
 936                 } else {
 937                         invoke_handlers valid_status_changed $newstate "Form disabled"
 938                 }
 939         }
 940 }
 941
 942
 943 body tlc::Form::textvariable_changed {newvalue} { #<<<1
 944         log debug "$name newvalue: ($newvalue)"
 945         array set tmp   $newvalue
 946         set existing    [array names dat]
 947         set new                 [array names tmp]
 948         array unset tmp
 949
 950         set removed_keys        [lindex [tlc::intersect3 $existing $new] 2]
 951         foreach key $removed_keys {
 952                 set dat($key)   ""
 953         }
 954
 955         set_data $newvalue
 956 }
 957
 958
 959 body tlc::Form::default_options {type args} { #<<<1
 960         set type        [canonize_type $type]
 961
 962         set default_options($type)      $args
 963 }
 964
 965
 966 body tlc::Form::canonize_type {type} { #<<<1
 967         switch -- $type {
 968                 ""                      -
 969                 entry           {return "entry"}
 970                 checkbox        -
 971                 checkbutton     {return "checkbutton"}
 972                 label           {return "label"}
 973                 vartextbox      -
 974                 textbox         -
 975                 text            {return "text"}
 976                 button          {return "button"}
 977                 combobox        -
 978                 mycombobox      {return "combobox"}
 979                 date            -
 980                 dateentry       {return "dateentry"}
 981                 calendar        {return "calendar"}
 982                 fileselect      {return "fileselect"}
 983                 list            {return "list"}
 984                 lookup          {return "lookup"}
 985                 spinint         {return "spinint"}
 986                 spinner         {return "spinner"}
 987                 message         {return "message"}
 988                 intentry        {return "intentry"}
 989                 tagentry        {return "tagentry"}
 990                 radiogroup      {return "radiogroup"}
 991                 checkgroup      {return "checkgroup"}
 992                 subform         -
 993                 form            {return "subform"}
 994                 tablelist       {return "tablelist"}
 995
 996                 default {
 997                         if {[info exists tlc::Form::custom_types($type)]} {
 998                                 return $type
 999                         } else {
1000                                 error "Unknown type: ($type)"
1001                         }
1002                 }
1003         }
1004 }
1005
1006
1007 body tlc::Form::cleanup {} { #<<<1
1008         #log warning "$w:[tlc::stackdump]"
1009         array unset toggles
1010         array unset valid_toggles
1011         array unset signals
1012         array unset dominos
1013 }
1014
1015
1016 body tlc::Form::widget_destroyed {} { #<<<1
1017         #log warning $w
1018         cleanup
1019         #log warning "$w done"
1020 }
1021
1022