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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 237 - (hide 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 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    

  ViewVC Help
Powered by ViewVC 1.1.26