/[webpac]/openisis/current/tcl/lib/mlcm.gui.tcl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /openisis/current/tcl/lib/mlcm.gui.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 237 - (show annotations)
Mon Mar 8 17:43:12 2004 UTC (18 years, 5 months ago) by dpavlin
File MIME type: application/x-tcl
File size: 5120 byte(s)
initial import of openisis 0.9.0 vendor drop

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

  ViewVC Help
Powered by ViewVC 1.1.26