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
  21         constructor {args} {}
  22         destructor {}
  23
  24         itk_option define -padding padding Padding 0 {need_rerender}
  25         itk_option define -tooltipdelay toolTipDelay ToolTipDelay 1500 {}
  26         itk_option define -tooltiptimeout toolTipTimeout ToolTipTimeout 3500 {}
  27         itk_option define -winding winding Winding v {need_rerender}
  28
  29         public {
  30                 variable schema {}
  31                 variable state  "normal"
  32                 variable name   ""
  33
  34                 method set_data {args}
  35                 method set_key {args}
  36                 method get_data {args}
  37                 method clear_data {}
  38                 method itemconfig {name args}
  39                 method path {name}
  40                 method path_by_var {varname}
  41                 method set_tips {args}
  42
  43                 method dirty_gate_ref {}        ;# Obsolete, use signal_ref form_dirty
  44                 method valid_gate_ref {}        ;# Obsolete, use signal_ref form_valid
  45                 method changed_dom_ref {}
  46                 method takefocus {}
  47                 method mark_dirty {state}
  48                 method item_attach_signal {name signal {sense normal}}
  49                 method item_attach_expression {name expression}
  50                 method varname_from_path {path}
  51                 method arm_dirty {state}
  52                 method force_form_valid_update {}
  53                 method valid_condition {new_condition desc fields}
  54                 method valid_signal {signal desc fields}
  55                 method default_options {type args}
  56         }
  57
  58         protected {
  59                 method textvariable_changed {newvalue}
  60                 method handlers_debug {lvl msg} {log $lvl $msg}
  61                 method widget_destroyed {}
  62         }
  63
  64         private {
  65                 variable dat
  66                 variable oldschema      {}
  67                 variable formvars       {}
  68                 variable paths
  69                 variable paths_by_var
  70                 variable tips           {}
  71                 variable toggles
  72                 variable valid_toggles
  73                 variable expressions
  74                 variable expression_lists
  75                 variable valid_conditions       {}
  76                 variable valid_signals
  77                 variable expr_seq       0
  78                 variable field_valid
  79                 variable dominos
  80                 variable default_options
  81
  82                 method rerender {}
  83                 method need_rerender {}
  84                 method dat_changed {n1 n2 op}
  85                 method clear_valid_conditions {}
  86                 method check_valid {}
  87                 method valid_changed {condition desc fields newstate}
  88                 method update_valid_desc {}
  89                 method enabled_changed {newstate}
  90                 method form_valid_reasons_changed {}
  91                 method canonize_type {type}
  92                 method cleanup {}
  93         }
  94 }
  95
  96
  97 configbody tlc::Form::schema { #<<<1
  98         set tips        {}
  99         set schema      [tlc::decomment $schema]
 100         need_rerender
 101 }
 102
 103
 104 configbody tlc::Form::state { #<<<1
 105         log debug "state: ($state)"
 106         [stategate_ref] configure -default [expr {$state == "normal"}]
 107 }
 108
 109
 110 configbody tlc::Form::tooltipdelay { #<<<1
 111         $w.tips configure -delay $itk_option(-tooltipdelay)
 112 }
 113
 114
 115 configbody tlc::Form::tooltiptimeout { #<<<1
 116         $w.tips configure -showtime $itk_option(-tooltiptimeout)
 117 }
 118
 119
 120 body tlc::Form::constructor {args} { #<<<1
 121         array set paths {}
 122         array set paths_by_var {}
 123         array set toggles {}
 124         array set valid_toggles {}
 125         array set expressions {}
 126         array set expression_lists {}
 127         array set valid_signals {}
 128         array set field_valid {}
 129         array set dominos {}
 130         array set default_options {}
 131
 132         tlc::Domino #auto dominos(need_rerender) -name "$w need_rerender"
 133         tlc::Domino #auto dominos(need_valid_desc_update) \
 134                         -name "$w need_valid_desc_update"
 135         tlc::Varwatch #auto signals(form_dirty) -name "$w form_dirty"
 136         tlc::Vardomino #auto dominos(changed) -name "$w changed" \
 137                         -textvariable [scope dat]
 138         $signals(form_dirty) attach_dirtyvar [scope dat]
 139         $signals(form_dirty) register_handler onchange_info [code $this dat_changed]
 140         tlc::Hoverbox $w.tips
 141         tlc::Hoverbox $w.valid_tips
 142         tlc::Gate #auto signals(enabled) -name "$w enabled" \
 143                         -mode "and" -default 1
 144         tlc::Gate #auto signals(form_valid) -name "$w form_valid" \
 145                         -mode "and" -default 1
 146         tlc::Domino #auto dominos(reasons_changed) -name "$w reasons_changed"
 147
 148         $signals(enabled) attach_input [stategate_ref]
 149         $signals(enabled) attach_output [code $this enabled_changed]
 150
 151         $dominos(reasons_changed) attach_output \
 152                         [code $this form_valid_reasons_changed]
 153         $signals(enabled) attach_output [list $dominos(reasons_changed) tip]
 154
 155         $dominos(need_rerender) attach_output [code $this rerender]
 156         $dominos(need_valid_desc_update) attach_output \
 157                         [code $this update_valid_desc]
 158
 159         eval itk_initialize $args
 160
 161         if {$name == ""} {
 162                 set name        $w
 163         } else {
 164                 log debug "Setting name ($name) for $w"
 165         }
 166 }
 167
 168
 169 body tlc::Form::destructor {} { #<<<1
 170         log debug $name
 171
 172         # Thse reference widgets that may not exist anymore (if we are here
 173         # because of destroy rather than delete object, for instance), and
 174         # the standard cleanup will have them change state, and hence try to
 175         # configure their widgets.  Doing this causes them to die before their
 176         # inputs, which stops them trying to update their outputs
 177         cleanup
 178         #foreach child [winfo children $w] {
 179         #       if {[itcl::is object -class tlc::Form $child]} {
 180         #               log debug "Pre-emptively deleting subform $child"
 181         #               delete object $child
 182         #       }
 183         #}
 184 }
 185
 186
 187 body tlc::Form::set_data {args} { #<<<1
 188         if {[llength $args] == 1} {
 189                 set data        [lindex $args 0]
 190         } else {
 191                 set data        $args
 192         }
 193         if {[llength $data] % 2 != 0} {
 194                 log error "Badly formatted data, must be a list of key value pairs"
 195                 error "Badly formatted data, must be a list of key value pairs" "" \
 196                                 [list data_format_error]
 197         }
 198
 199         $signals(form_dirty) disarm
 200         array set dat $data
 201
 202         check_valid
 203         foreach {varname exprs} [array get expression_lists] {
 204                 foreach exprname $exprs {
 205                         $expressions($exprname) reassess
 206                 }
 207         }
 208
 209         $signals(form_dirty) arm
 210         if {[$signals(form_dirty) is_armed]} {
 211                 $signals(form_dirty) set_state 0
 212         }
 213 }
 214
 215
 216 body tlc::Form::set_key {args} { #<<<1
 217         log debug $name
 218         switch -- [llength $args] {
 219                 0 {error "No key specified" "" [list syntax_error no_key_specified]}
 220                 1 {error "No value specified" "" [list syntax_error no_value_specified]}
 221                 2 {
 222                         set key [lindex $args 0]
 223                         set val [lindex $args 1]
 224                         return [set_data $key $val]
 225                 }
 226         }
 227
 228         set key         [lindex $args 0]
 229         set keys        [lrange $args 1 end-1]
 230         set val         [lindex $args end]
 231         set handler     [path_by_var $key]
 232         if {[itcl::is object $handler] && [$handler isa tlc::Form]} {
 233                 eval [list $handler set_key] $keys [list $val]
 234                 set dat($key)   [$handler get_data]
 235         } else {
 236                 # TODO: recursive setter that composes the nested array list on unwind
 237                 error "Only subforms are currently supported for deep key sets" "" \
 238                                 [list not_implemented]
 239         }
 240 }
 241
 242
 243 body tlc::Form::get_data {args} { #<<<1
 244         $dominos(need_rerender) force_if_pending
 245
 246         if {[llength $args] == 0} {
 247                 return [array get dat]
 248         } elseif {[llength $args] == 1} {
 249                 set key         [lindex $args 0]
 250                 if {![info exists dat($key)]} {
 251                         error "Bad key: \"$key\", should be one of [join [array names tmp] {, }]" "" \
 252                                         [list bad_key [list $key]]
 253                 }
 254                 return $dat($key)
 255         } else {
 256                 set last        [array get dat]
 257                 set so_far      {}
 258                 foreach key $args {
 259                         array unset tmp
 260                         try {
 261                                 array set tmp   $last
 262                         } onerr {
 263                                 default {
 264                                         error "Cannot build array from key level [llength $so_far] \"[join $so_far ->]\": $errmsg" "" \
 265                                                         [list format_error $so_far]
 266                                 }
 267                         }
 268                         lappend so_far  $key
 269                         if {![info exists tmp($key)]} {
 270                                 error "Bad key: \"[join $so_far ->]\", should be one of [join [array names tmp] {, }]" "" \
 271                                                 [list bad_key $so_far]
 272                         }
 273                         set last        $tmp($key)
 274                 }
 275                 return $last
 276         }
 277 }
 278
 279
 280 body tlc::Form::dirty_gate_ref {} { #<<<1
 281         log warning "dirty_gate_ref deprecated, use \"signal_ref form_dirty\" instead"
 282         return $signals(form_dirty)
 283 }
 284
 285
 286 body tlc::Form::rerender {} { #<<<1
 287         if {$schema == $oldschema} return
 288         log debug $name
 289
 290         set_data        {}
 291         $signals(form_dirty) disarm
 292         catch {eval destroy [lindex [tlc::intersect3 [winfo children $w] [list $w.tips $w.valid_tips]] 0]}
 293
 294         # Layout context init
 295         array set layout {
 296                 label_col_args_sticky           {}
 297                 label_cell_args_sticky          {-anchor ne}
 298                 label_widget_args_sticky        {}
 299                 cell_args_sticky                        {-anchor nw}
 300                 col_args_sticky                         {}
 301         }
 302         set layout(row_args_sticky)             [list -pady $itk_option(-padding)]
 303
 304         catch {unset paths}; array set paths {}
 305         catch {unset paths_by_var}; array set paths_by_var {}
 306         catch {unset toggles}; array set toggles {}
 307         catch {unset valid_toggles}; array set valid_toggles {}
 308         catch {unset field_valid}; array set field_valid {}
 309         catch {unset valid_signals}; array set valid_signals {}
 310         catch {unset expressions}
 311         catch {unset expression_lists}
 312         clear_valid_conditions
 313         set formvars    {}
 314         set row         0
 315         set col         0
 316         set reset       1
 317         foreach {label info} $schema {
 318                 set varname             ""
 319                 set type                ""
 320                 set arglist             ""
 321
 322                 if {$reset} {
 323                         set layout(label_cell_args)             $layout(label_cell_args_sticky)
 324                         set layout(label_col_args)              $layout(label_col_args_sticky)
 325                         set layout(label_widget_args)   $layout(label_widget_args_sticky)
 326                         set layout(cell_args)                   $layout(cell_args_sticky)
 327                         set layout(row_args)                    $layout(row_args_sticky)
 328                         set layout(col_args)                    $layout(col_args_sticky)
 329                 }
 330
 331                 if {[string index $label 0] == "_"} {
 332                         switch -- $label {
 333                                 _layout         { #<<<
 334                                         if {$label == "_layout"} {
 335                                                 switch -- [lindex $info 0] {
 336                                                         cell_args_sticky                        -
 337                                                         row_args_sticky                         -
 338                                                         col_args_sticky                         -
 339                                                         label_cell_args_sticky          -
 340                                                         label_widget_args_sticky        -
 341                                                         label_col_args_sticky           {
 342                                                                 set layout([lindex $info 0])    [lrange $info 1 end]
 343                                                                 set layout([string range [lindex $info 0] 0 end-7]) \
 344                                                                                 [lrange $info 1 end]
 345                                                         }
 346                                                         label_args_sticky {
 347                                                                 log warning "_layout label_args_sticky is deprecated - use label_cell_args_sticky"
 348                                                                 set layout(label_cell_args_sticky)      [lrange $info 1 end]
 349                                                                 set layout(label_cell_args) \
 350                                                                                 [lrange $info 1 end]
 351                                                         }
 352
 353                                                         cell_args                       -
 354                                                         row_args                        -
 355                                                         col_args                        -
 356                                                         label_col_args          -
 357                                                         label_widget_args       -
 358                                                         label_cell_args {
 359                                                                 set layout([lindex $info 0])    [lrange $info 1 end]
 360                                                                 set reset       0
 361                                                         }
 362                                                         label_args      {
 363                                                                 log warning "_layout label_args is deprecated - use label_cell_args"
 364                                                                 set layout(label_cell_args)             [lrange $info 1 end]
 365                                                                 set reset       0
 366                                                         }
 367
 368                                                         next_row                        -
 369                                                         next_col                        -
 370                                                         next_column                     {
 371                                                                 switch -- [string index $itk_option(-winding) 0] {
 372                                                                         "h" {
 373                                                                                 incr row        1
 374                                                                                 set col         0
 375                                                                                 set layout(row_args)    $layout(row_args_sticky)
 376                                                                         }
 377
 378                                                                         default -
 379                                                                         "v" {
 380                                                                                 incr col        2
 381                                                                                 set row         0
 382                                                                                 set layout(col_args)    $layout(col_args_sticky)
 383                                                                         }
 384                                                                 }
 385                                                         }
 386
 387                                                         skip_cols                       -
 388                                                         skip_columns            -
 389                                                         skip_rows                       -
 390                                                         skip_col                        -
 391                                                         skip_column                     -
 392                                                         skip_row                        {
 393                                                                 switch -- [string index $itk_option(-winding) 0] {
 394                                                                         "h" {
 395                                                                                 set amnt        [lindex $info 1]
 396                                                                                 if {$amnt == ""} {set amnt      1}
 397                                                                                 incr col        $amnt
 398                                                                                 incr col        $amnt
 399                                                                         }
 400
 401                                                                         default -
 402                                                                         "v" {
 403                                                                                 set amnt        [lindex $info 1]
 404                                                                                 if {$amnt == ""} {set amnt      1}
 405                                                                                 incr row        $amnt
 406                                                                         }
 407                                                                 }
 408                                                         }
 409
 410                                                         default_options         {
 411                                                                 log warning "default_options mode of _layout is deprecated.  Use top level directive _default_options instead"
 412                                                                 set type        [canonize_type [lindex $info 1]]
 413                                                                 set default_options($type)      [lrange $info 2 end]
 414                                                         }
 415
 416                                                         default {
 417                                                                 error "Unrecognised layout parameter: ([lindex $info 0])"
 418                                                         }
 419                                                 }
 420                                         }
 421                                         #>>>
 422                                 }
 423                                 _validation - _validation_not_blank { #<<<
 424                                         if {$label == "_validation"} {
 425                                                 valid_condition [lindex $info 0] [lindex $info 1] [lindex $info 2]
 426                                         }
 427                                         if {$label == "_validation_not_blank"} {
 428                                                 set template    [lindex $info 0]
 429                                                 foreach {labelname varname} [lrange $info 1 end] {
 430                                                         set condition   "\[string trim \$dat([string map {{ } {\ } {)} {\)}} $varname])\] != {}"
 431                                                         valid_condition \
 432                                                                         $condition \
 433                                                                         [string map [list %1 $labelname] $template] \
 434                                                                         [list $varname]
 435                                                 }
 436                                         }
 437                                         #>>>
 438                                 }
 439                                 _tips - _tooltips { #<<<
 440                                         set_tips $info
 441                                         #>>>
 442                                 }
 443                                 _defaults { #<<<
 444                                         array set dat   $info
 445                                         #>>>
 446                                 }
 447                                 _default_options { #<<<
 448                                         set type        [canonize_type [lindex $info 0]]
 449                                         set default_options($type)      [lrange $info 1 end]
 450                                         #>>>
 451                                 }
 452                                 default {
 453                                         error "Invalid meta directive \"$label\", must be one of _layout, _validation, _validation_not_blank, _tips or _tooltips" "" [list invalid_meta_directive $label]
 454                                 }
 455                         }
 456
 457                         continue
 458                 }
 459
 460                 set reset       1
 461
 462                 foreach {varname type} $info break
 463                 lappend formvars        $varname
 464                 set type                        [canonize_type $type]
 465
 466                 if {[info exists default_options($type)]} {
 467                         set arglist     [concat $default_options($type) [lrange $info 2 end]]
 468                 } else {
 469                         set arglist     [lrange $info 2 end]
 470                 }
 471
 472                 if {[string index $label 0] == " "} {
 473                         label $w.$row,$col,l -text "" -width 0 -highlightthickness 0 \
 474                                         -background $itk_option(-background)
 475                 } else {
 476                         label $w.$row,$col,l -text $label \
 477                                         -background $itk_option(-background)
 478                 }
 479                 if {[llength $layout(label_widget_args)] > 0} {
 480                         eval [list $w.$row,$col,l configure] $layout(label_widget_args)
 481                 }
 482
 483                 if {![info exists dat($varname)]} {
 484                         set dat($varname)       ""
 485                 }
 486                 if {[string first " " $varname] != -1} {
 487                         # Itcl bug (still as of 3.3) prevents scope / resolver working
 488                         # with arrays whose keys contain spaces.  We craft our own here
 489                         # that works with the resolver
 490
 491                         # Works, but ugly
 492                         #set scoped_varname     "[list @itcl $this] [namespace current]::dat($varname)"
 493                         set tmp         [scope dat($varname)]
 494                         set scoped_varname      [concat [lrange $tmp 0 1] [lindex $tmp 2]]
 495                 } else {
 496                         set scoped_varname      [scope dat($varname)]
 497                 }
 498
 499                 tlc::Gate #auto field_valid($varname) -name "$w field_valid $varname" \
 500                                 -mode "and" -default 1
 501                 tlc::StateToggle #auto valid_toggles($varname) \
 502                                         -mode "or" -default 1 \
 503                                 $w.$row,$col,l \
 504                                         -foreground {red black}
 505                 $valid_toggles($varname) attach_signal $signals(enabled) inverted
 506                 $valid_toggles($varname) attach_signal $field_valid($varname)
 507
 508                 $valid_toggles($varname) attach_output \
 509                                 [list $dominos(reasons_changed) tip]
 510
 511                 set toggle                      {-state {disabled normal}}
 512                 switch -- $type {
 513                         entry {
 514                                 entry $w.$row,$col,v -textvariable $scoped_varname
 515                         }
 516
 517                         checkbutton {
 518                                 checkbutton $w.$row,$col,v -variable $scoped_varname
 519                         }
 520
 521                         label {
 522                                 label $w.$row,$col,v -textvariable $scoped_varname \
 523                                                 -justify left \
 524                                                 -font [$tlc::theme setting boldfont]
 525                         }
 526
 527                         text {
 528                                 tlc::vartextbox $w.$row,$col,v -textvariable $scoped_varname
 529                         }
 530
 531                         button {
 532                                 button $w.$row,$col,v
 533                         }
 534
 535                         combobox {
 536                                 tlc::mycombobox $w.$row,$col,v -textvariable $scoped_varname
 537                         }
 538
 539                         dateentry {
 540                                 tlc::Dateentry $w.$row,$col,v -textvariable $scoped_varname
 541                         }
 542
 543                         calendar {
 544                                 tlc::Calendar $w.$row,$col,v -command [code set dat($varname)]
 545                         }
 546
 547                         fileselect {
 548                                 tlc::Fileselectbox $w.$row,$col,v -textvariable $scoped_varname
 549                         }
 550
 551                         list {
 552                                 tlc::Browse_treeview_list $w.$row,$col,v \
 553                                                 -textvariable $scoped_varname \
 554                                                 -width 300 -height 110
 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