| 1 |
|
| 2 |
package provide mlcm::gui 0.1 |
| 3 |
|
| 4 |
namespace eval mlcm::gui { |
| 5 |
|
| 6 |
variable _gid 0 |
| 7 |
|
| 8 |
proc _newwindow {} { |
| 9 |
variable _gid |
| 10 |
return ".top[incr _gid]" |
| 11 |
} |
| 12 |
|
| 13 |
proc _activate btn { |
| 14 |
set bg1 [$btn cget -background] |
| 15 |
set bg2 [$btn cget -activebackground] |
| 16 |
if ![string equal $bg1 $bg2] { |
| 17 |
$btn configure -background $bg2 |
| 18 |
after 200 $btn configure -background $bg1 |
| 19 |
$btn invoke |
| 20 |
} |
| 21 |
} |
| 22 |
|
| 23 |
proc _button args { |
| 24 |
set res [eval button $args] |
| 25 |
if [catch { |
| 26 |
set under [$res cget -underline] |
| 27 |
set key [$res cget -text] |
| 28 |
if {0 <= $under} { |
| 29 |
set key [string index $key $under] |
| 30 |
bind . <Alt-KeyPress-$key> "mlcm::gui::_activate $res" |
| 31 |
puts "bound $key to $res" |
| 32 |
} |
| 33 |
}] { |
| 34 |
global errorInfo |
| 35 |
puts $errorInfo |
| 36 |
} |
| 37 |
return $res |
| 38 |
} |
| 39 |
|
| 40 |
proc _header {that frm db} { |
| 41 |
set maxrow [$db get maxrow] |
| 42 |
set scrw $frm.dbhead |
| 43 |
tixScrolledWindow $scrw |
| 44 |
pack $scrw -side left -expand yes -fill both |
| 45 |
set panel [$scrw subwidget window] |
| 46 |
set lbl [label $panel.maxrow -text "[mlcm::lang::msg maxrow]: $maxrow"] |
| 47 |
set bf [_button $panel.first -command "mlcm::gui::_dbfirst $db" \ |
| 48 |
-text [mlcm::lang::msg first] -underline 0] |
| 49 |
set bp [_button $panel.prev -command "mlcm::gui::_dbprev $db" \ |
| 50 |
-text [mlcm::lang::msg prev] -underline 0] |
| 51 |
set bn [_button $panel.next -command "mlcm::gui::_dbnext $db" \ |
| 52 |
-text [mlcm::lang::msg next] -underline 0] |
| 53 |
set bl [_button $panel.last -command "mlcm::gui::_dblast $db" \ |
| 54 |
-text [mlcm::lang::msg last] -underline 0] |
| 55 |
pack $panel.maxrow $panel.first $panel.prev $panel.next \ |
| 56 |
$panel.last -side left |
| 57 |
} |
| 58 |
|
| 59 |
proc _dbfirst {db} { |
| 60 |
puts "first [$db name]" |
| 61 |
} |
| 62 |
|
| 63 |
proc _dbprev {db} { |
| 64 |
puts "prev [$db name]" |
| 65 |
} |
| 66 |
|
| 67 |
proc _dbnext {db} { |
| 68 |
puts "next [$db name]" |
| 69 |
} |
| 70 |
|
| 71 |
proc _dblast {db} { |
| 72 |
puts "last [$db name]" |
| 73 |
} |
| 74 |
|
| 75 |
proc _workarea {that frm db} { |
| 76 |
set pnw $frm.pnw |
| 77 |
tixPanedWindow $pnw -orientation horizontal |
| 78 |
pack $pnw -side top -expand yes -fill both |
| 79 |
$pnw add pane1 -size 444 |
| 80 |
$pnw add pane2 |
| 81 |
|
| 82 |
# left area: result set list |
| 83 |
set htmlw $pnw.pane1.text |
| 84 |
set scb $pnw.pane1.scby |
| 85 |
html $htmlw |
| 86 |
scrollbar $scb -command "$htmlw yview" |
| 87 |
$htmlw configure -yscrollcommand "$scb set" |
| 88 |
pack $scb -side right -expand no -fill y |
| 89 |
pack $htmlw -side right -expand yes -fill both |
| 90 |
|
| 91 |
$that add html $htmlw |
| 92 |
|
| 93 |
# right area: TBD |
| 94 |
label $pnw.pane2.lbl -text "edit me" |
| 95 |
pack $pnw.pane2.lbl -side left -expand yes -fill both |
| 96 |
} |
| 97 |
|
| 98 |
# create new gui hierarchy for db |
| 99 |
# @param parent parent window where to put the gui into |
| 100 |
# if empty, a new toplevel window is created |
| 101 |
# @param profile actual profile to use |
| 102 |
# @param db actual database to use |
| 103 |
# @return gui record |
| 104 |
proc new {parent profile db} { |
| 105 |
set that [openIsisRec -fdt $mlcm::meta::fdtGui] |
| 106 |
set top 0 |
| 107 |
set path $parent |
| 108 |
if ![string length $parent] { |
| 109 |
set parent [_newwindow] |
| 110 |
toplevel $parent |
| 111 |
set path $parent. |
| 112 |
} elseif [string equal . $parent] { |
| 113 |
set top 1 |
| 114 |
} { |
| 115 |
set path $parent. |
| 116 |
set top 2 |
| 117 |
} |
| 118 |
|
| 119 |
$that add top $parent db $db stub [$db stub] |
| 120 |
|
| 121 |
set main ${path}main |
| 122 |
if $top { |
| 123 |
destroy $main |
| 124 |
} |
| 125 |
frame $main |
| 126 |
pack $main -side top -fill both -expand yes |
| 127 |
|
| 128 |
set actmenu [$profile menu] |
| 129 |
set mbar [frame $main.menubar -bd 5] |
| 130 |
pack $mbar -side top -fill x |
| 131 |
mlcm::menu::showmenu $actmenu $mbar |
| 132 |
|
| 133 |
set fhead [frame $main.frhead] |
| 134 |
pack $fhead -side top -expand no -fill x |
| 135 |
_header $that $fhead $db |
| 136 |
|
| 137 |
set fwork [frame $main.workarea] |
| 138 |
pack $fwork -side top -expand yes -fill both |
| 139 |
_workarea $that $fwork $db |
| 140 |
|
| 141 |
if $top { |
| 142 |
wm title $parent "MLCM - [$db name]" |
| 143 |
if {2 == $top} { |
| 144 |
wm geom $parent 500x400+80+80 |
| 145 |
} |
| 146 |
} |
| 147 |
return $that |
| 148 |
} |
| 149 |
|
| 150 |
# setup global/openIsis variables for active window |
| 151 |
proc activate that { |
| 152 |
set stb [$that get stub] |
| 153 |
set openIsis::srv $stb |
| 154 |
set htmlw [$that get html] |
| 155 |
proc ::openIsis::puts msg " |
| 156 |
$htmlw parse \$msg |
| 157 |
" |
| 158 |
} |
| 159 |
|
| 160 |
# show all db entries |
| 161 |
proc all that { |
| 162 |
set db [$that get db] |
| 163 |
set htmlw [$that get html] |
| 164 |
$htmlw clear |
| 165 |
catch { |
| 166 |
set tsp [tsp list $db] |
| 167 |
set dbn [$db name] |
| 168 |
for {$db all} {[$db hasNext]} {} { |
| 169 |
set mfn [$db next] |
| 170 |
if ![openIsis::isis read -rowid $mfn -db $dbn] { |
| 171 |
puts "no record for mfn $mfn" |
| 172 |
continue |
| 173 |
} |
| 174 |
if [catch {openIsis::Tspr $tsp}] { |
| 175 |
global errorInfo |
| 176 |
puts "error in $tsp:\n$errorInfo" |
| 177 |
break |
| 178 |
} |
| 179 |
} |
| 180 |
} |
| 181 |
} |
| 182 |
|
| 183 |
proc _chktsp {name dbn path res} { |
| 184 |
upvar $res ret |
| 185 |
set ret "$path/$dbn.$name" |
| 186 |
if [file readable $ret] { |
| 187 |
return 1 |
| 188 |
} |
| 189 |
set ret "$path/$name" |
| 190 |
file readable $ret |
| 191 |
} |
| 192 |
|
| 193 |
# find tsp file |
| 194 |
# first, look for <path_of_db>/<name_of_db>.<tsp>.tsp |
| 195 |
# second, look for <path_of_db>/<tsp>.tsp |
| 196 |
# third, scan $::auto_path for <name_of_db>.<tsp>.tsp |
| 197 |
# fourth, scan $::auto_path for <tsp>.tsp |
| 198 |
# fifth, raise an error |
| 199 |
# @param tsp name of tsp file without extension |
| 200 |
# @param db actual databse object |
| 201 |
# @return path to tsp file |
| 202 |
proc tsp {tsp db} { |
| 203 |
global auto_path |
| 204 |
set tsp "$tsp.tsp" |
| 205 |
set dbn [$db name] |
| 206 |
set path "$auto_path" |
| 207 |
catch { |
| 208 |
set cfg [$db get 4002] |
| 209 |
set dbp [$cfg get {803 {}}] |
| 210 |
if [string length $dbp] { |
| 211 |
set path "$dbp $auto_path" |
| 212 |
} |
| 213 |
} |
| 214 |
set res "" |
| 215 |
foreach p "$path" { |
| 216 |
if [_chktsp $tsp $dbn $p res] { |
| 217 |
return $res |
| 218 |
} |
| 219 |
} |
| 220 |
error "cannot find $tsp in $path" |
| 221 |
} |
| 222 |
} |
| 223 |
|
Parent Directory
| 
Revision Log