DrS
First of all...thank you very much for your advice.
I'm not sure if your fix is appropriate for the real thing so here it is.
That single line you mentioned does make the real program "work" too
so perhaps I didn't too bad a job of replicating the problem this time but...
I hear you re introducing extra bugs by supplying a proxy for the real thing.
I'm very impressed that members might be happy to trawl through my badly written code i.e. this is my first proper Tcl program and I know I understand very little at the moment.
In any case thank you and Best Regards
Dean
#=====================================================================
package require Tktable
set gRows 10 ;#change to suit
proc ? {x} {
set answer [tk_messageBox -message $x -type yesno -icon question]
switch -- $answer {
yes {}
no exit
}
}
#not used
proc this_proc_nm {} {? [lindex [info level -1] 0]}
proc col_names_in_tbl {tbl_nm} {
#use to set up number of cols in display table
set col_names_ln [db::qry "SELECT sql FROM sqlite_master
WHERE tbl_name = '$tbl_nm'
AND type = 'table';"]
set res [regexp -nocase {\([^)]+\)} $col_names_ln between_brackets]
set removed_brackets [string range $between_brackets 1 end-1]
set lCol_names [split $removed_brackets ,]
set retLst {}
foreach subLst $lCol_names {
set col_nm [lindex $subLst 0]
lappend retLst $col_nm
}
#? "col_names_in_tbl for $tbl_nm is \n$retLst"
return $retLst
}
proc cols_in_tbl {tbl_nm} {
#use to set up number of cols in display table
#? "tbl_nm supplied to cols_in_tbl is $tbl_nm"
set txt [db::qry "SELECT sql FROM sqlite_master
WHERE tbl_name = '$tbl_nm'
AND type = 'table';"]
set res [regexp -nocase {\([^)]+\)} $txt mtch]
#? "mtch is $mtch"
set col_list [split $mtch ,]
set no_of_cols [llength $col_list]
return $no_of_cols
#here's an alternative
#set cls [db::qry "PRAGMA table_info('$tbl_nm');"]
#? "cls is $cls"
}
proc l2a {upLst upArr cols} {
upvar 1 $upLst l
upvar 0 $upArr a
set r 0
set c 0
foreach ele $l {
set a($r,$c) $ele
incr c
if {$c >= $cols} {set c 0; incr r}
}
}
namespace eval db { ;#================================
set hDb {}
proc db_open {{path ":memory:"}} {
package require sqlite3
sqlite3 hDb $path ;#set path "[pwd]\\vlu.db" ;#":memory:"
}
proc db_close {} {hDb close} ;#to externally close db
proc qry {txt} {return [hDb eval "$txt;"]}
}
namespace eval ns1 { ;#================================
#here's an example of the format you need for table contents
#array set aStd_nms_tbl_var {
# 0,0 raw_nm1 0,1 "fld0,1"
# 1,0 raw_nm2 1,1 "fld1,1"
#}
set std_nms_ntry_var ""
set raw_nms_ntry_var ""
array set aStd_nms_tbl_var {}
array set aRaw_nms_tbl_var {}
proc hndlr_ntry_Tab {tbl key} {
set top [expr {[$tbl cget -roworigin] + [$tbl cget -titlerows]}]
set left [expr {[$tbl cget -colorigin] + [$tbl cget -titlecols]}]
::tk::table::BeginSelect $tbl $top,$left
::tk::table::CancelRepeat
$tbl activate $top,$left
}
proc hndlr_ntry_BackSpace {ntry key} {
global gPartial_std_nm glAll_std_nms gL gMax_display_cols
upvar 2 gCells cells ;#wow needed to up the level to 2 from 1 (ie level in hndlr_ntry_std_nm)
set gL [gDb eval "SELECT nm, itm_typ FROM std_nms;"]
set pttrn [string range $gPartial_std_nm 0 end-1]
set gMax_display_rows [.fMain.fStd_nm.tStd_nms cget -rows]
.fMain.fStd_nm.tStd_nms delete rows -- 0 $gMax_display_rows
array unset cells
set r 0
foreach {nm typ} $gL {
if {$pttrn == ""} {
.fMain.fStd_nm.tStd_nms insert rows end
set cells($r,0) $nm
set cells($r,1) typ
incr r
} else {
set mtch ""
set res [regexp -nocase "^$pttrn.*" $nm mtch]
#? "ok checking $pttrn against $nm and mtch is $mtch"
if {$mtch != ""} {
.fMain.fStd_nm.tStd_nms insert rows end
set cells($r,0) $nm
set cells($r,1) typ
incr r
}
}
}
set gMax_display_rows [.fMain.fStd_nm.tStd_nms cget -rows]
.fMain.fStd_nm.tStd_nms delete rows -- $gMax_display_rows $gMax_display_rows
}
proc hndlr_ntry_Return {ntry key} {
? "in hndlr_ntry_Return"
}
proc hndlr_ntry_default {ntry key} {
? "in hndlr_ntry_default"
}
proc hndlr_ntry_main {key} {
set instigating_ntry [focus -displayof .f]
set corresponding_tbl [tk_focusNext $instigating_ntry]
switch $key {
Tab {hndlr_ntry_Tab $corresponding_tbl key}
BackSpace {hndlr_ntry_BackSpace $instigating_ntry key}
Return {hndlr_ntry_Return $instigating_ntry key}
default {hndlr_ntry_default $instigating_ntry key}
}
}
#this seems to be redundant cos of the bind statements
proc hndlr_tbl_main {caller key} {
switch $key {
#Tab {hndlr_ntry_tab caller key}
#Tab {hndlr_ntry_tab caller key}
#Tab {hndlr_ntry_tab caller key}
#default {? "unknown proc $caller calling hndlr_tbl_main"}
}
}
proc std_nms_combo {aSttngs aTbl_cells} {
upvar 1 $aSttngs aS
global gRows
set ns [uplevel 1 {namespace current}] ;#arjen
set this_proc_nm [lindex [info level 0] 0]
frame .f.f1 -bd 2 -relief groove
grid .f.f1 -column $aS(col) -row $aS(row) -columnspan 1 -rowspan 2 -sticky nsew
entry .f.f1.n1 -textvariable $aS(ntry_vlu)
grid .f.f1.n1 -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky nsew
bind .f.f1.n1 <Key> "ns1::hndlr_ntry_main %K"
table .f.f1.t1 \
-rows $gRows \
-cols [cols_in_tbl std_nms] \
-variable ${ns}::$aTbl_cells \
-titlerows 1
grid .f.f1.t1 -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky nsew
.f.f1.t1 tag configure active -bg red -relief raised -showtext 1
.f.f1.t1 tag configure tag_not_active -bg lavender -relief raised -showtext 1
bind .f.f1.t1 <Key> {
switch %K {
Up {ns1::tbl_Up .f.f1.t1 [%W index active row] [%W index active col]}
Down {ns1::tbl_Down .f.f1.t1 [%W index active row] [%W index active col]}
space {
ns1::tbl_space .f.f1.t1 [%W index active row] [%W index active col]
break
}
Tab {}
default {break}
}
}
bind .f.f1.t1 <<TraverseIn>> {ns1::hndl_TraverseIn_tbl .f.f1.t1}
}
proc raw_nms_combo {aSttngs aTbl_cells} {
upvar 1 $aSttngs aS
global gRows
set ns [uplevel 1 {namespace current}] ;#arjen
set this_proc_nm [lindex [info level 0] 0]
frame .f.f2 -bd 2 -relief groove
grid .f.f2 -column $aS(col) -row $aS(row) -columnspan 1 -rowspan 2 -sticky nsew
entry .f.f2.n -textvariable $aS(ntry_vlu)
grid .f.f2.n -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky nsew
#bind .f.f2.n <Key> "ns1::hndlr_raw_nm_ntry %K"
bind .f.f2.n <Key> "ns1::hndlr_ntry_main %K"
#Scrollbars have a -command which they call
#whenever the user interacts with them.
#Scrollable widgets use -xscrollcommand
#and -yscrollcommand to communicate with their Scrollbars
#(for example, so the Scrollbar knows
#how large to make the "elevator" and where to place it in the trough).
#An example of hooking up a vertical scrollbar:
# text .t -yscrollcommand {.f.f2.sbar set}
# scrollbar .f.f2.sbar -orient vertical -command {.f.f2.t yview}
#scrollbar .
f.f2.sb -command [list .f.f2.t yview]
scrollbar .f.f2.sbar -orient vertical -command {.f.f2.t yview}
table .f.f2.t \
-rows $gRows \
-cols [cols_in_tbl raw_nms] \
-variable ${ns}::$aTbl_cells \
-titlerows 1 \
-yscrollcommand {.f.f2.sbar set}
grid .f.f2.sbar -column 1 -row 1 -columnspan 1 -rowspan 1 -sticky nsew
;#new
#pathName width ?col? ?value col value ...?
.f.f2.t width 1 60
grid .f.f2.t -column 0 -row 1 -columnspan 1 -rowspan 1 -sticky nsew
#bind .f.f2.t <Key> "ns1::hndlr_std_nm_tbl %K"
#bind .f.f2.t <Key> "ns1::hndlr_tbl_main $this_proc_nm %K"
.f.f2.t tag configure active -bg red -relief raised -showtext 1
.f.f2.t tag configure tag_not_active -bg lavender -relief raised -showtext 1
bind .f.f2.t <Key> {
switch %K {
Up {
ns1::tbl_Up .f.f2.t [%W index active row] [%W index active col]
}
Down {
ns1::tbl_Down .f.f2.t [%W index active row] [%W index active col]
}
space {
ns1::tbl_space .f.f2.t [%W index active row] [%W index active col]
break
}
Tab {
}
default {
break
}
}
}
bind .f.f2.t <<TraverseIn>> {ns1::hndl_TraverseIn_tbl .f.f2.t}
#bind .f.f2.t <<TraverseOut>> {ns1::hndl_TraverseOut_tbl .f.f2.t}
#Drs fixed my bug with
.f.f2.t config -rows 100
}
#================================================
proc tbl_Up {tbl active_row active_col} {
global gRows
set cls [$tbl cget -cols]
if {$active_row < 1} {return}
for {set r 0} {$r < $gRows} {incr r} {
for {set c 0} {$c < $cls} {incr c} {
if {$r != [expr $active_row - 1]} { ;#+1 cos need next cell
$tbl tag celltag tag_not_active $r,$c
} else {
$tbl tag celltag active $r,$c
}
}
}
}
proc tbl_Down {tbl active_row active_col} {
global gRows
set cls [$tbl cget -cols]
if {$active_row > $cls} {return}
for {set r 0} {$r < $gRows} {incr r} {
for {set c 0} {$c < $cls} {incr c} {
if {$r == [expr $active_row + 1]} { ;#+1 cos need next cell
$tbl tag celltag active $r,$c
} else {
#this stops pressing down arrow to many times from messing up last row highlighting
if {$r < [expr $gRows - 1]} {
$tbl tag celltag tag_not_active $r,$c
}
}
}
}
}
proc tbl_space {tbl active_row active_col} {
? "active_row is $active_row"
}
proc blob {} {
? "menu option chosen"
}
proc hndl_TraverseIn_tbl {tbl} {
#define the active tag's properties
global gRows
$tbl tag configure active -bg red -relief raised -showtext 1
for {set r 0} {$r < $gRows} {incr r} {
for {set c 0} {$c < [$tbl cget -cols]} {incr c} {
if {$r != 0} { ;#i wanted to say gActive_cell here but default tabbing in tktable seems to put it in first row
$tbl tag celltag tag_not_active $r,$c
} else {
#give cells in same row as active cell...active tag so they have the same colour
$tbl tag celltag active $r,$c
}
}
}
}
proc hndl_TraverseOut_tbl {tbl} {
#although not used keep this cos shows how to clear highlighted line
global gRows
for {set r 0} {$r < $gRows} {incr r} {
for {set c 0} {$c < 2} {incr c} {
$tbl tag celltag tag_not_active $r,$c
}
}
$tbl tag configure active -bg lavender -relief raised -showtext 1
}
#================================================
#main
array set aStd_nms_combo_settings {
combo_frame .f.f1
col 0
row 0
ntry_vlu ""
ntry_hndlr_proc hndlr_std_nm_ntry
tbl_hndlr_proc hndlr_std_nm_tbl
}
array set aRaw_nms_combo_settings {
parent .fMain
col 1
row 0
ntry_vlu ""
ntry_hndlr_proc hndlr_raw_nm_ntry
tbl_hndlr_proc hndlr_raw_nm_tbl
}
proc blob {} {? "yes blob"}
#i added this to close db later so could harness db::qry from hndl_TraverseIn
#cos db was closing before calling cols_in_tbl
#actually I'm still having problems
proc menu_show {} {
menu .mbar
. configure -menu .mbar
menu .
mbar.fm -tearoff 0
.mbar add cascade -menu .
mbar.fm -label options -underline 0
#to call methods from global menu scope dont use {} with -command ie just []
.
mbar.fm add command -label "add statement" -underline 0 -command {ns1::blob}
.
mbar.fm add command -label "clear statement" -underline 0 -command {ns1::blob}
.
mbar.fm add command -label Exit -underline 0 -command {
? "warning closing database and ."
db::db_close
destroy .
}
}
#text .t
#scrollbar .sby -orient vert
#pack .sby .t -expand yes -fill both -side right
#.t conf -yscrollcommand {.sby set}
#.sby conf -command {.t yview}
#main
menu_show
toplevel .w
frame .f -bd 2 -relief groove
grid .f -column 0 -row 0 -columnspan 2 -rowspan 2 -sticky nsew
db::db_open [pwd]\\vlu.db
set l [db::qry "SELECT * FROM std_nms;"]
set l [lsort -stride [cols_in_tbl std_nms] -index 1 -ascii $l]
set hdngs [col_names_in_tbl std_nms]
set l [lappend hdngs {*}$l]
l2a ns1::l ns1::aStd_nms_tbl_var [cols_in_tbl std_nms]
std_nms_combo aStd_nms_combo_settings aStd_nms_tbl_var
set l [db::qry "SELECT * FROM raw_nms;"]
set l [lsort -stride [cols_in_tbl raw_nms] -index 1 -ascii $l]
set hdngs [col_names_in_tbl raw_nms]
set l [lappend hdngs {*}$l]
l2a ns1::l ns1::aRaw_nms_tbl_var [cols_in_tbl raw_nms]
raw_nms_combo aRaw_nms_combo_settings aRaw_nms_tbl_var
#
#=====================================================================
# #new stuff
# #=====================================================================
} ;#eonamespace ns1