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 |
|