examples/testform.itcl

   1 #!/tcl8.4/bin/tclsh8.4
   2 #!/tcl8.5/bin/tclsh8.5
   3
   4 source "boilerplate.tcl"
   5
   6 tlc::Signal #auto flipflop
   7 tlc::Signal #auto alwaysfalse
   8 $alwaysfalse set_state 1
   9
  10 proc lookup {id name} {
  11         return [list 1 1 "Test"]
  12 }
  13
  14 Form .form -tooltipdelay 300 -schema {
  15         "Name"          {name label}
  16         "Dep1"          {dep1 checkbutton}
  17         _layout         skip_row
  18         "Child 3"       {child3 vartextbox}
  19         "Child 4"       {{child 4} date}
  20         "Child 5"       {child5 lookup}
  21         "GE1"           {ge1 entry}
  22         "GE2"           {ge2 entry}
  23         "GE3"           {ge3 entry}
  24         "GE4"           {ge4 entry}
  25         "GE5"           {{ge 5)d} entry}
  26         "Browselist"    {
  27                                 browselist list
  28                                         -headers {Foo Bar} -item_schema {"Foo" {Foo date} "Bar" Bar}
  29                                         -column_widths {Foo 50}
  30                         }
  31         _layout         {next_column}
  32         "Child 1"       {child1 entry}
  33         "Child 2"       {child2 checkbutton}
  34         "Tag Entry"     {testtag tagentry -policy space}
  35         _validation     {
  36                 {[string first "boo" $dat(child3)] != -1}
  37                 "Child 3 must contain \"boo\""
  38                 {child3}
  39         }
  40         _validation     {
  41                 {$dat(child2) == $dat(dep1)}
  42                 "Dep1 and Child 2 must agree"
  43                 {child2 dep1}
  44         }
  45         _validation {
  46                 {$dat(child1) == "Hello World"}
  47                 "Child 1 must be \"Hello World\""
  48                 {child1}
  49         }
  50         _validation_not_blank {
  51                 "%1 must be filled in"
  52                 "GE1"   ge1
  53                 "GE2"   ge2
  54                 "GE4"   ge4
  55                 "GE5"   {ge 5)d}
  56         }
  57 }
  58
  59 label .valid -text "Not valid"
  60
  61 .form itemconfig "Child 1" -width 4
  62
  63 .form set_tips {
  64         "Child 1"       "This is an entry box!"
  65         "Dep1"          "This checkbox controlls many other elements"
  66 }
  67
  68 .form itemconfig "Child 5" -lookup_command lookup
  69 Tools .tools
  70 .tools add "Update" {.form mark_dirty 0} right
  71 .tools add "Show Data" {
  72         array unset tmp
  73         array set tmp   [.form get_data]
  74         parray tmp
  75 } right
  76 .tools add "Close" {exit} right
  77 .tools attach_signal "Update" [.form dirty_gate_ref]
  78
  79 proc update_valid_status {isvalid desclist} {
  80         puts "update_valid_status: ($isvalid) ($desclist)"
  81         .tools set_tips "Update" [join $desclist \n]
  82 }
  83
  84 .form register_handler valid_status_changed update_valid_status
  85 .form force_form_valid_update
  86
  87 .form set_data {
  88         name    "Test form"
  89         child1  "Inital"
  90 }
  91
  92 .form attach_signal $alwaysfalse
  93 .form attach_signal $flipflop
  94
  95 set checked     [.form item_attach_expression "Dep1" {$value == 1}]
  96
  97 .form item_attach_signal "Child 1" $checked
  98 .form item_attach_signal "Child 2" $checked inverted
  99 .form item_attach_signal "Child 3" $checked
 100 .form item_attach_signal "Child 4" $checked
 101 .form item_attach_signal "Child 5" $checked
 102
 103 StateToggle #auto toggles(valid_feedback) .valid \
 104                 -text {"Not Valid" "Valid"}
 105 $toggles(valid_feedback) attach_signal [.form valid_gate_ref]
 106
 107 proc flipflop {} {
 108         puts "\n"
 109         $::flipflop toggle_state
 110         puts "flipflop: ([$::flipflop state])"
 111         .form set_data [list name [lindex {disabled enabled} [$::flipflop state]]]
 112         after 3000 flipflop
 113         #puts "gate: [.form explaingate]"
 114 }
 115
 116 pack .form -side top -fill both -expand true
 117 pack .valid -side top -anchor w
 118 pack .tools -side top -fill x
 119
 120 wm deiconify .
 121
 122 $flipflop set_state 1
 123
 124 flipflop