96 lines
1.9 KiB
Tcl
96 lines
1.9 KiB
Tcl
#!/bin/sh
|
|
# the next line restarts using wish \
|
|
exec wish "$0" ${1+"$@"}
|
|
|
|
## valid.tcl
|
|
##
|
|
## This demos shows the use of the validation mechanism of the table
|
|
## and uses the table's cache (no -command or -variable)
|
|
##
|
|
## jeff at hobbs org
|
|
|
|
source [file join [file dirname [info script]] loadtable.tcl]
|
|
|
|
array set table {
|
|
rows 10
|
|
cols 10
|
|
table .table
|
|
}
|
|
|
|
proc colorize num {
|
|
if {$num>0 && $num%2} { return colored }
|
|
}
|
|
|
|
proc fill_headers {w {r 10} {c 10}} {
|
|
for {set i 1} {$i < $r} {incr i} {
|
|
$w set $i,0 "$i"
|
|
}
|
|
for {set j 1} {$j < $c} {incr j} {
|
|
if {$j%3==1} {
|
|
$w set 0,$j AlphaNum
|
|
} elseif {$j%2==1} {
|
|
$w set 0,$j Alpha
|
|
} elseif {$j} {
|
|
$w set 0,$j Real
|
|
}
|
|
}
|
|
}
|
|
|
|
proc validate {c val} {
|
|
if {$c%3==1} {
|
|
## Alphanum
|
|
set expr {^[A-Za-z0-9 ]*$}
|
|
} elseif {$c%2==1} {
|
|
## Alpha
|
|
set expr {^[A-Za-z ]*$}
|
|
} elseif {$c} {
|
|
## Real
|
|
set expr {^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}
|
|
}
|
|
if {[regexp $expr $val]} {
|
|
return 1
|
|
} else {
|
|
bell
|
|
return 0
|
|
}
|
|
}
|
|
|
|
label .example -text "TkTable v1 Validated Table Example"
|
|
|
|
set t $table(table)
|
|
table $t \
|
|
-rows $table(rows) \
|
|
-cols $table(cols) \
|
|
-cache 1 \
|
|
-titlerows 1 \
|
|
-titlecols 1 \
|
|
-yscrollcommand { .tsy set } \
|
|
-xscrollcommand { .tsx set } \
|
|
-width 5 -height 5 \
|
|
-coltagcommand colorize \
|
|
-flashmode on \
|
|
-selectmode extended \
|
|
-colstretch unset \
|
|
-rowstretch unset \
|
|
-validate yes \
|
|
-vcmd {if {![%W tag includes title %C]} { validate %c %S } }
|
|
|
|
fill_headers $t
|
|
$t tag config colored -bg lightblue
|
|
$t tag config title -fg red
|
|
$t width 0 3
|
|
|
|
scrollbar .tsy -command [list $t yview]
|
|
scrollbar .tsx -command [list $t xview] -orient horizontal
|
|
button .exit -text "Exit" -command {exit}
|
|
|
|
grid .example - -sticky ew
|
|
grid $t .tsy -sticky news
|
|
grid .tsx -sticky ew
|
|
grid .exit - -sticky ew
|
|
grid columnconfig . 0 -weight 1
|
|
grid rowconfig . 1 -weight 1
|
|
|
|
puts [list Table is $table(table)]
|
|
|