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_tktreectrl_list $w.$row,$col,v \
 554                                                 -textvariable $scoped_varname
 555                         }
 556
 557                         lookup {
 558                                 tlc::Lookup $w.$row,$col,v -textvariable $scoped_varname
 559                         }
 560
 561                         spinint {
 562                                 tlc::Spinint $w.$row,$col,v -textvariable $scoped_varname
 563                         }
 564
 565                         spinner {
 566                                 tlc::Spinner $w.$row,$col,v -textvariable $scoped_varname
 567                                 # TODO: wire valid_signal?
 568                         }
 569
 570                         message {
 571                                 message $w.$row,$col,v \
 572                                                 -textvariable $scoped_varname \
 573                                                 -font [$tlc::theme setting boldfont]
 574                                 set toggle      {}
 575                         }
 576
 577                         intentry {
 578                                 entry $w.$row,$col,v -textvariable $scoped_varname \
 579                                                 -validate all \
 580                                                 -validatecommand {string is integer {%P}}
 581                         }
 582
 583                         tagentry {
 584                                 Tagentry $w.$row,$col,v -textvariable $scoped_varname
 585                         }
 586
 587                         radiogroup {
 588                                 tlc::Radiogroup $w.$row,$col,v -textvariable $scoped_varname
 589                         }
 590
 591                         checkgroup {
 592                                 tlc::Checkgroup $w.$row,$col,v -textvariable $scoped_varname
 593                         }
 594
 595                         subform {
 596                                 tlc::Form $w.$row,$col,v -textvariable $scoped_varname \
 597                                                 -name "$name -> $varname"
 598                                 valid_signal [$w.$row,$col,v signal_ref form_valid] "" $varname
 599                         }
 600
 601                         tablelist {
 602                                 tlc::Tablelist $w.$row,$col,v -textvariable $scoped_varname
 603                                 # TODO: wire valid_signal?
 604                         }
 605
 606                         default {
 607                                 if {[info exists tlc::Form::custom_types($type)]} {
 608                                         $tlc::Form::custom_types($type) $w.$row,$col,v \
 609                                                         -textvariable $scoped_varname
 610                                 } else {
 611                                         log error "Unknown type: ($type)"
 612                                         continue
 613                                 }
 614                         }
 615                 }
 616                 set paths($label)                       $w.$row,$col,v
 617                 set paths_by_var($varname)      $w.$row,$col,v
 618                 eval [list tlc::StateToggle #auto toggles($varname) $w.$row,$col,v] \
 619                                 $toggle
 620                 $toggles($varname) attach_signal $signals(enabled)
 621
 622                 if {[llength $arglist] != 0} {
 623                         eval [list $w.$row,$col,v configure] $arglist
 624                 }
 625
 626                 set dc          [expr {$col+1}]
 627                 eval [list blt::table $w $w.$row,$col,l $row,$col] \
 628                                 $layout(label_cell_args)
 629                 blt::table configure $w c$col -resize none
 630                 eval [list blt::table $w $w.$row,$col,v $row,$dc] $layout(cell_args)
 631                 eval [list blt::table configure $w c$col] $layout(label_col_args)
 632                 eval [list blt::table configure $w c$dc] $layout(col_args)
 633                 eval [list blt::table configure $w r$row] $layout(row_args)
 634
 635                 switch -- [string index $itk_option(-winding) 0] {
 636                         "h" {
 637                                 incr col 2
 638                         }
 639
 640                         default -
 641                         "v" {
 642                                 incr row
 643                         }
 644                 }
 645         }
 646
 647         set_tips $tips
 648
 649         update idletasks
 650         if {![info exists signals(form_dirty)]} {
 651                 log error "Freak out - signals(form_dirty) missing\n$w\n[tlc::stackdump]"
 652                 return
 653         }
 654         $signals(form_dirty) arm
 655         $signals(form_dirty) set_state 0
 656 }
 657
 658
 659 body tlc::Form::takefocus {} { #<<<1
 660         $dominos(need_rerender) force_if_pending
 661         focus $w.0,0,v
 662 }
 663
 664
 665 body tlc::Form::need_rerender {} { #<<<1
 666         $dominos(need_rerender) tip
 667 }
 668
 669
 670 body tlc::Form::itemconfig {name args} { #<<<1
 671         set path        [path $name]
 672         eval [list $path configure] $args
 673 }
 674
 675
 676 body tlc::Form::path {name} { #<<<1
 677         $dominos(need_rerender) force_if_pending
 678
 679         if {[string is integer -strict $name]} {
 680                 if {[winfo exists $w.$name,0,v]} {
 681                         return $w.$name,0,v
 682                 } else {
 683                         error "No such item index: ($name)"
 684                 }
 685         } elseif {[regexp {[0-9]+,[0-9]+} $name]} {
 686                 foreach {r c} [split $name ,] break
 687                 if {[winfo exists $w.$r,$c,v]} {
 688                         return $w.$r,$c,v
 689                 } else {
 690                         error "No such item index: ($name)"
 691                 }
 692         } else {
 693                 if {![info exists paths($name)]} {
 694                         error "No such form item: ($name), choose from (\"[join [array names paths] {", "}]\")"
 695                 }
 696                 return $paths($name)
 697         }
 698 }
 699
 700
 701 body tlc::Form::changed_dom_ref {} { #<<<1
 702         return $dominos(changed)
 703 }
 704
 705
 706 body tlc::Form::set_tips {args} { #<<<1
 707         if {[llength $args] == 1} {
 708                 # Support the variant syntax of one item packed with all the tips
 709                 # (for convenience)
 710                 set args        [lindex $args 0]
 711         }
 712         foreach {label tip} $args {
 713                 set widget      [path $label]
 714                 $w.tips attach $widget $tip
 715         }
 716         set tips        $args
 717 }
 718
 719
 720 body tlc::Form::mark_dirty {state} { #<<<1
 721         log debug
 722         $signals(form_dirty) set_state $state
 723 }
 724
 725
 726 body tlc::Form::path_by_var {varname} { #<<<1
 727         $dominos(need_rerender) force_if_pending
 728
 729         if {![info exists paths_by_var($varname)]} {
 730                 error "No such form item: ($varname)" "" \
 731                                 [list invalid_form_item $varname]
 732         }
 733         return $paths_by_var($varname)
 734 }
 735
 736 body tlc::Form::dat_changed {n1 n2 op} { #<<<1
 737         if {$op == "w"} {
 738                 log debug "dat($n2) changed: ($dat($n2))"
 739         } elseif {$op == "u"} {
 740                 log debug "dat($n2) unset"
 741         }
 742         set_textvariable [get_data]
 743
 744         if {[$signals(form_dirty) is_armed]} {
 745                 check_valid
 746                 if {[info exists dat($n2)]} {
 747                         if {[info exists expression_lists($n2)]} {
 748                                 foreach exprname $expression_lists($n2) {
 749                                         $expressions($exprname) reassess
 750                                 }
 751                         }
 752                         invoke_handlers onchange,$n2 $dat($n2)
 753                 }
 754                 invoke_handlers onchange [array get dat]
 755
 756                 $signals(form_dirty) set_state 1
 757         }
 758 }
 759
 760
 761 body tlc::Form::clear_data {} { #<<<1
 762         log debug $name
 763         $signals(form_dirty) disarm
 764         #array unset dat
 765         #array set dat {}
 766         # TODO: figure out why this is necessary
 767         foreach key [array names dat] {
 768                 set dat($key)   ""
 769         }
 770
 771         #array unset toggles
 772         #array set toggles {}
 773         #array unset expressions
 774         $signals(form_dirty) set_state 0
 775         $signals(form_dirty) arm
 776 }
 777
 778
 779 body tlc::Form::item_attach_signal {name signal {sense normal}} { #<<<1
 780         set path        [path $name]
 781         set varname     [varname_from_path $path]
 782         $toggles($varname) attach_signal $signal $sense
 783 }
 784
 785
 786 body tlc::Form::item_attach_expression {name expression} { #<<<1
 787         set path        [path $name]
 788         set varname     [varname_from_path $path]
 789         #array unset expressions $varname
 790         set exprname    "$varname[incr expr_seq]"
 791         tlc::Expression #auto expressions($exprname) -name "Form expression on $varname ($exprname)"
 792         lappend expression_lists($varname)      $exprname
 793         set expression  [string map [list \$value %<dat($varname)%>] $expression]
 794         $expressions($exprname) set_expression $expression
 795
 796         return $expressions($exprname)
 797 }
 798
 799
 800 body tlc::Form::varname_from_path {path} { #<<<1
 801         set ok  0
 802         foreach {v p} [array get paths_by_var] {
 803                 if {$p == $path} {
 804                         set varname     $v
 805                         set ok  1
 806                         break
 807                 }
 808         }
 809
 810         if {$ok} {
 811                 return $varname
 812         } else {
 813                 error "No varname known for path: ($path)"
 814         }
 815 }
 816
 817
 818 body tlc::Form::arm_dirty {state} { #<<<1
 819         log debug
 820         if {$state} {
 821                 $signals(form_dirty) arm
 822         } else {
 823                 $signals(form_dirty) disarm
 824         }
 825 }
 826
 827
 828 body tlc::Form::valid_gate_ref {} { #<<<1
 829         log warning "valid_gate_ref deprecated, use \"signal_ref form_valid\" instead"
 830         return $signals(form_valid)
 831 }
 832
 833
 834 body tlc::Form::valid_condition {new_condition desc fields} { #<<<1
 835         tlc::Signal #auto valid_signals($new_condition) -name "valid_signals($new_condition)"
 836         lappend valid_conditions        [list $new_condition $desc $fields $valid_signals($new_condition)]
 837
 838         foreach field $fields {
 839                 $field_valid($field) attach_input $valid_signals($new_condition)
 840                 $valid_toggles($field) attach_output \
 841                                 [code $this valid_changed $new_condition $desc $fields]
 842         }
 843
 844         check_valid
 845
 846         $signals(form_valid) attach_input $valid_signals($new_condition)
 847 }
 848
 849
 850 body tlc::Form::valid_signal {signal desc fields} { #<<<1
 851         $dominos(need_rerender) force_if_pending
 852
 853         lappend valid_conditions        [list {} $desc $fields $signal]
 854
 855         foreach field $fields {
 856                 $field_valid($field) attach_input $signal
 857                 $valid_toggles($field) attach_output \
 858                                 [code $this valid_changed {} $desc $fields]
 859         }
 860
 861         $signals(form_valid) attach_input $signal
 862 }
 863
 864
 865 body tlc::Form::check_valid {} { #<<<1
 866         foreach condition_desc $valid_conditions {
 867                 foreach {condition desc fields signal} $condition_desc break
 868                 if {$condition != {}} {
 869                         $signal set_state [expr $condition]
 870                 }
 871         }
 872 }
 873
 874
 875 body tlc::Form::clear_valid_conditions {} { #<<<1
 876         set valid_conditions    {}
 877         check_valid
 878 }
 879
 880
 881
 882 body tlc::Form::valid_changed {condition desc fields newstate} { #<<<1
 883         $dominos(need_valid_desc_update) tip
 884 }
 885
 886
 887 body tlc::Form::update_valid_desc {} { #<<<1
 888         array set new_desc      {}
 889
 890         foreach condition_desc $valid_conditions {
 891                 foreach {condition desc fields signal} $condition_desc break
 892                 foreach field $fields {
 893                         if {![$valid_toggles($field) state]} {
 894                                 lappend new_desc($field)        $desc
 895                         }
 896                 }
 897         }
 898
 899         set obsolete    [lindex [tlc::intersect3 [array names paths_by_var] [array names new_desc]] 0]
 900         foreach field $obsolete {
 901                 $w.valid_tips detach [$valid_toggles($field) target]
 902         }
 903         foreach {field desclist} [array get new_desc] {
 904                 $w.valid_tips attach [$valid_toggles($field) target] [join $desclist \n]
 905         }
 906 }
 907
 908
 909 body tlc::Form::force_form_valid_update {} { #<<<1
 910         form_valid_reasons_changed
 911 }
 912
 913
 914 body tlc::Form::enabled_changed {newstate} { #<<<1
 915         if {!($newstate)} {
 916                 $w.valid_tips popdown
 917         }
 918 }
 919
 920
 921 body tlc::Form::form_valid_reasons_changed {} { #<<<1
 922         set newstate    [$signals(form_valid) state]
 923         if {$newstate} {
 924                 invoke_handlers valid_status_changed $newstate {}
 925         } else {
 926                 if {[$signals(enabled) state]} {
 927                         set reasons     {}
 928                         foreach condition_desc $valid_conditions {
 929                                 foreach {condition desc fields signal} $condition_desc break
 930                                 if {![$signal state]} {
 931                                         lappend reasons $desc
 932                                 }
 933                         }
 934                         invoke_handlers valid_status_changed $newstate $reasons
 935                 } else {
 936                         invoke_handlers valid_status_changed $newstate "Form disabled"
 937                 }
 938         }
 939 }
 940
 941
 942 body tlc::Form::textvariable_changed {newvalue} { #<<<1
 943         log debug "$name newvalue: ($newvalue)"
 944         array set tmp   $newvalue
 945         set existing    [array names dat]
 946         set new                 [array names tmp]
 947         array unset tmp
 948
 949         set removed_keys        [lindex [tlc::intersect3 $existing $new] 2]
 950         foreach key $removed_keys {
 951                 set dat($key)   ""
 952         }
 953
 954         set_data $newvalue
 955 }
 956
 957
 958 body tlc::Form::default_options {type args} { #<<<1
 959         set type        [canonize_type $type]
 960
 961         set default_options($type)      $args
 962 }
 963
 964
 965 body tlc::Form::canonize_type {type} { #<<<1
 966         switch -- $type {
 967                 ""                      -
 968                 entry           {return "entry"}
 969                 checkbox        -
 970                 checkbutton     {return "checkbutton"}
 971                 label           {return "label"}
 972                 vartextbox      -
 973                 textbox         -
 974                 text            {return "text"}
 975                 button          {return "button"}
 976                 combobox        -
 977                 mycombobox      {return "combobox"}
 978                 date            -
 979                 dateentry       {return "dateentry"}
 980                 calendar        {return "calendar"}
 981                 fileselect      {return "fileselect"}
 982                 list            {return "list"}
 983                 lookup          {return "lookup"}
 984                 spinint         {return "spinint"}
 985                 spinner         {return "spinner"}
 986                 message         {return "message"}
 987                 intentry        {return "intentry"}
 988                 tagentry        {return "tagentry"}
 989                 radiogroup      {return "radiogroup"}
 990                 checkgroup      {return "checkgroup"}
 991                 subform         -
 992                 form            {return "subform"}
 993                 tablelist       {return "tablelist"}
 994
 995                 default {
 996                         if {[info exists tlc::Form::custom_types($type)]} {
 997                                 return $type
 998                         } else {
 999                                 error "Unknown type: ($type)"
1000                         }
1001                 }
1002         }
1003 }
1004
1005
1006 body tlc::Form::cleanup {} { #<<<1
1007         #log warning "$w:[tlc::stackdump]"
1008         array unset toggles
1009         array unset valid_toggles
1010         array unset signals
1011         array unset dominos
1012 }
1013
1014
1015 body tlc::Form::widget_destroyed {} { #<<<1
1016         #log warning $w
1017         cleanup
1018         #log warning "$w done"
1019 }
1020
1021