| 1 |
dpavlin |
237 |
|
| 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