source: trunk/BWidget-1.2.1/mainframe.tcl @ 931

Last change on this file since 931 was 931, checked in by toby, 11 years ago

include rest of files

File size: 17.2 KB
Line 
1# ------------------------------------------------------------------------------
2#  mainframe.tcl
3#  This file is part of Unifix BWidget Toolkit
4#  $Id: mainframe.tcl,v 1.8 1999/07/09 08:10:33 eric Exp $
5# ------------------------------------------------------------------------------
6#  Index of commands:
7#     - MainFrame::create
8#     - MainFrame::configure
9#     - MainFrame::cget
10#     - MainFrame::getframe
11#     - MainFrame::addtoolbar
12#     - MainFrame::gettoolbar
13#     - MainFrame::addindicator
14#     - MainFrame::getindicator
15#     - MainFrame::getmenu
16#     - MainFrame::showtoolbar
17#     - MainFrame::showstatusbar
18#     - MainFrame::_create_menubar
19#     - MainFrame::_create_entries
20#     - MainFrame::_parse_name
21#     - MainFrame::_parse_accelerator
22# ------------------------------------------------------------------------------
23
24namespace eval MainFrame {
25    ProgressBar::use
26
27    Widget::bwinclude MainFrame ProgressBar .status.prg \
28        remove {
29            -fg -bg -bd -troughcolor -background -borderwidth
30            -relief -orient -width -height
31        } \
32        rename {
33            -maximum    -progressmax
34            -variable   -progressvar
35            -type       -progresstype
36            -foreground -progressfg
37        }
38
39    Widget::declare MainFrame {
40        {-width        TkResource 0      0 frame}
41        {-height       TkResource 0      0 frame}
42        {-background   TkResource ""     0 frame}
43        {-textvariable String     ""     0}
44        {-menu         String     {}     1}
45        {-separator    Enum       both   1 {none top bottom both}}
46        {-bg           Synonym    -background}
47    }
48
49    Widget::addmap MainFrame "" .frame  {-width {} -height {} -background {}}
50    Widget::addmap MainFrame "" .topf   {-background {}}
51    Widget::addmap MainFrame "" .botf   {-background {}}
52    Widget::addmap MainFrame "" .status {-background {}}
53    Widget::addmap MainFrame "" .status.label {-background {}}
54    Widget::addmap MainFrame "" .status.indf  {-background {}}
55    Widget::addmap MainFrame "" .status.prgf  {-background {}}
56    Widget::addmap MainFrame ProgressBar .status.prg {-background {} -background -troughcolor}
57
58    proc ::MainFrame { path args } { return [eval MainFrame::create $path $args] }
59    proc use {} {}
60
61    variable _widget
62}
63
64
65# ------------------------------------------------------------------------------
66#  Command MainFrame::create
67# ------------------------------------------------------------------------------
68proc MainFrame::create { path args } {
69    global   tcl_platform
70    variable _widget
71
72    set path [frame $path -takefocus 0 -highlightthickness 0]
73    set top  [winfo parent $path]
74    if { [string compare [winfo toplevel $path] $top] } {
75        destroy $path
76        return -code error "parent must be a toplevel"
77    }
78    Widget::init MainFrame $path $args
79
80    set bg [Widget::getoption $path -background]
81    if { $tcl_platform(platform) == "unix" } {
82        set relief raised
83        set bd     1
84    } else {
85        set relief flat
86        set bd     0
87    }
88    $path configure -background $bg
89    set topframe  [frame $path.topf -relief flat -borderwidth 0 -background $bg]
90    set userframe [eval frame $path.frame [Widget::subcget $path .frame] \
91                       -relief $relief -borderwidth $bd]
92    set botframe  [frame $path.botf -relief $relief -borderwidth $bd -background $bg]
93
94    pack $topframe -fill x
95    grid columnconfigure $topframe 0 -weight 1
96
97    if { $tcl_platform(platform) != "unix" } {
98        set sepopt [Widget::getoption $path -separator]
99        if { $sepopt == "both" || $sepopt == "top" } {
100            set sep [Separator::create $path.sep -orient horizontal -background $bg]
101            pack $sep -fill x
102        }
103        if { $sepopt == "both" || $sepopt == "bottom" } {
104            set sep [Separator::create $botframe.sep -orient horizontal -background $bg]
105            pack $sep -fill x
106        }
107    }
108
109    # --- status bar -------------------------------------------------------------------------
110    set status   [frame $path.status -relief flat -borderwidth 0 \
111                      -takefocus 0 -highlightthickness 0 -background $bg]
112    set label    [label $status.label -textvariable [Widget::getoption $path -textvariable] \
113                      -takefocus 0 -highlightthickness 0 -background $bg]
114    set indframe [frame $status.indf -relief flat -borderwidth 0 \
115                      -takefocus 0 -highlightthickness 0 -background $bg]
116    set prgframe [frame $status.prgf -relief flat -borderwidth 0 \
117                      -takefocus 0 -highlightthickness 0 -background $bg]
118
119    place $label    -anchor w -x 0 -rely 0.5
120    place $indframe -anchor e -relx 1 -rely 0.5
121    pack  $prgframe -in $indframe -side left -padx 2
122    $status configure -height [winfo reqheight $label]
123
124    set progress [eval ProgressBar::create $status.prg [Widget::subcget $path .status.prg] \
125                      -width       50 \
126                      -height      [expr {[winfo reqheight $label]-2}] \
127                      -borderwidth 1 \
128                      -relief      sunken]
129    pack $status    -in $botframe -fill x -pady 2
130    pack $botframe  -side bottom -fill x
131    pack $userframe -fill both -expand yes
132
133    set _widget($path,top)      $top
134    set _widget($path,ntoolbar) 0
135    set _widget($path,nindic)   0
136
137    set menu [Widget::getoption $path -menu]
138    if { [llength $menu] } {
139        _create_menubar $path $menu
140    }
141
142    bind $path <Destroy> {MainFrame::_destroy %W}
143
144    rename $path ::$path:cmd
145    proc ::$path { cmd args } "return \[eval MainFrame::\$cmd $path \$args\]"
146
147    return $path
148}
149
150
151# ------------------------------------------------------------------------------
152#  Command MainFrame::configure
153# ------------------------------------------------------------------------------
154proc MainFrame::configure { path args } {
155    variable _widget
156
157    set res [Widget::configure $path $args]
158
159    if { [Widget::hasChanged $path -textvariable newv] } {
160        uplevel \#0 $path.status.label configure -textvariable [list $newv]
161    }
162
163    if { [Widget::hasChanged $path -background bg] } {
164        set listmenu [$_widget($path,top) cget -menu]
165        while { [llength $listmenu] } {
166            set newlist {}
167            foreach menu $listmenu {
168                $menu configure -background $bg
169                set newlist [concat $newlist [winfo children $menu]]
170            }
171            set listmenu $newlist
172        }
173        foreach sep {.sep .botf.sep} {
174            if { [winfo exists $path.$sep] } {
175                Separator::configure $path.$sep -background $bg
176            }
177        }
178        foreach w [winfo children $path.topf] {
179            $w configure -background $bg
180        }
181    }
182    return $res
183}
184
185
186# ------------------------------------------------------------------------------
187#  Command MainFrame::cget
188# ------------------------------------------------------------------------------
189proc MainFrame::cget { path option } {
190    return [Widget::cget $path $option]
191}
192
193
194# ------------------------------------------------------------------------------
195#  Command MainFrame::getframe
196# ------------------------------------------------------------------------------
197proc MainFrame::getframe { path } {
198    return $path.frame
199}
200
201
202# ------------------------------------------------------------------------------
203#  Command MainFrame::addtoolbar
204# ------------------------------------------------------------------------------
205proc MainFrame::addtoolbar { path } {
206    global   tcl_platform
207    variable _widget
208
209    set index     $_widget($path,ntoolbar)
210    set toolframe $path.topf.f$index
211    set toolbar   $path.topf.tb$index
212    set bg        [Widget::getoption $path -background]
213    if { $tcl_platform(platform) == "unix" } {
214        frame $toolframe -relief raised -borderwidth 1 \
215            -takefocus 0 -highlightthickness 0 -background $bg
216    } else {
217        frame $toolframe -relief flat -borderwidth 0 -takefocus 0 \
218            -highlightthickness 0 -background $bg
219        set sep [Separator::create $toolframe.sep -orient horizontal -background $bg]
220        pack $sep -fill x
221    }
222    set toolbar [frame $toolbar -relief flat -borderwidth 2 \
223                     -takefocus 0 -highlightthickness 0 -background $bg]
224    pack $toolbar -in $toolframe -anchor w
225    incr _widget($path,ntoolbar)
226    grid $toolframe -column 0 -row $index -sticky ew
227    return $toolbar
228}
229
230
231# ------------------------------------------------------------------------------
232#  Command MainFrame::gettoolbar
233# ------------------------------------------------------------------------------
234proc MainFrame::gettoolbar { path index } {
235    return $path.topf.tb$index
236}
237
238
239# ------------------------------------------------------------------------------
240#  Command MainFrame::addindicator
241# ------------------------------------------------------------------------------
242proc MainFrame::addindicator { path args } {
243    variable _widget
244
245    set index $_widget($path,nindic)
246    set indic $path.status.indf.f$index
247    eval label $indic $args -relief sunken -borderwidth 1 \
248        -takefocus 0 -highlightthickness 0
249
250    pack $indic -side left -anchor w -padx 2
251
252    incr _widget($path,nindic)
253
254    return $indic
255}
256
257
258# ------------------------------------------------------------------------------
259#  Command MainFrame::getindicator
260# ------------------------------------------------------------------------------
261proc MainFrame::getindicator { path index } {
262    return $path.status.indf.f$index
263}
264
265
266# ------------------------------------------------------------------------------
267#  Command MainFrame::getmenu
268# ------------------------------------------------------------------------------
269proc MainFrame::getmenu { path menuid } {
270    variable _widget
271
272    if { [info exists _widget($path,menuid,$menuid)] } {
273        return $_widget($path,menuid,$menuid)
274    }
275    return ""
276}
277
278
279# ------------------------------------------------------------------------------
280#  Command MainFrame::setmenustate
281# ------------------------------------------------------------------------------
282proc MainFrame::setmenustate { path tag state } {
283    variable _widget
284
285    if { [info exists _widget($path,tags,$tag)] } {
286        foreach {menu entry} $_widget($path,tags,$tag) {
287            $menu entryconfigure $entry -state $state
288        }
289    }
290}
291
292
293# ------------------------------------------------------------------------------
294#  Command MainFrame::showtoolbar
295# ------------------------------------------------------------------------------
296proc MainFrame::showtoolbar { path index bool } {
297    variable _widget
298
299    set toolframe $path.topf.f$index
300    if { [winfo exists $toolframe] } {
301        if { !$bool && [llength [grid info $toolframe]] } {
302            grid forget $toolframe
303            $path.topf configure -height 1
304        } elseif { $bool && ![llength [grid info $toolframe]] } {
305            grid $toolframe -column 0 -row $index -sticky ew
306        }
307    }
308}
309
310
311# ------------------------------------------------------------------------------
312#  Command MainFrame::showstatusbar
313# ------------------------------------------------------------------------------
314proc MainFrame::showstatusbar { path name } {
315    set status $path.status
316    if { ![string compare $name "none"] } {
317        pack forget $status
318    } else {
319        pack $status -fill x
320        switch -- $name {
321            status {
322                catch {pack forget $status.prg}
323            }
324            progression {
325                pack $status.prg -in $status.prgf
326            }
327        }
328    }
329}
330
331
332# ------------------------------------------------------------------------------
333#  Command MainFrame::_destroy
334# ------------------------------------------------------------------------------
335proc MainFrame::_destroy { path } {
336    variable _widget
337
338    Widget::destroy $path
339    catch {destroy [$_widget($path,top) cget -menu]}
340    $_widget($path,top) configure -menu {}
341    unset _widget($path,top)
342    unset _widget($path,ntoolbar)
343    unset _widget($path,nindic)
344    rename $path {}
345}
346
347
348# ------------------------------------------------------------------------------
349#  Command MainFrame::_create_menubar
350# ------------------------------------------------------------------------------
351proc MainFrame::_create_menubar { path descmenu } {
352    variable _widget
353    global    tcl_platform
354
355    set bg      [Widget::getoption $path -background]
356    set top     $_widget($path,top)
357    if { $tcl_platform(platform) == "unix" } {
358        set menubar [menu $top.menubar -tearoff 0 -background $bg -borderwidth 1]
359    } else {
360        set menubar [menu $top.menubar -tearoff 0 -background $bg]
361    }
362    $top configure -menu $menubar
363
364    set count 0
365    foreach {name tags menuid tearoff entries} $descmenu {
366        set opt  [_parse_name $name]
367        if { [string length $menuid] && ![info exists _widget($path,menuid,$menuid)] } {
368            # menu has identifier
369            # we use it for its pathname, to enable special menu entries
370            # (help, system, ...)
371            set menu $menubar.$menuid
372        } else {
373            set menu $menubar.menu$count
374        }
375        eval $menubar add cascad $opt -menu $menu
376        menu $menu -tearoff $tearoff -background $bg
377        foreach tag $tags {
378            lappend _widget($path,tags,$tag) $menubar $count
379        }
380        if { [string length $menuid] } {
381            # menu has identifier
382            set _widget($path,menuid,$menuid) $menu
383        }
384        _create_entries $path $menu $bg $entries
385        incr count
386    }
387}
388
389
390# ------------------------------------------------------------------------------
391#  Command MainFrame::_create_entries
392# ------------------------------------------------------------------------------
393proc MainFrame::_create_entries { path menu bg entries } {
394    variable _widget
395
396    set count      [$menu cget -tearoff]
397    set registered 0
398    foreach entry $entries {
399        set len  [llength $entry]
400        set type [lindex $entry 0]
401
402        if { ![string compare $type "separator"] } {
403            $menu add separator
404            incr count
405            continue
406        }
407
408        # entry name and tags
409        set opt  [_parse_name [lindex $entry 1]]
410        set tags [lindex $entry 2]
411        foreach tag $tags {
412            lappend _widget($path,tags,$tag) $menu $count
413        }
414
415        if { ![string compare $type "cascad"] } {
416            set menuid  [lindex $entry 3]
417            set tearoff [lindex $entry 4]
418            set submenu $menu.menu$count
419            eval $menu add cascad $opt -menu $submenu
420            menu $submenu -tearoff $tearoff -background $bg
421            if { [string length $menuid] } {
422                # menu has identifier
423                set _widget($path,menuid,$menuid) $submenu
424            }
425            _create_entries $path $submenu $bg [lindex $entry 5]
426            incr count
427            continue
428        }
429
430        # entry help description
431        set desc [lindex $entry 3]
432        if { [string length $desc] } {
433            if { !$registered } {
434                DynamicHelp::register $menu menu [Widget::getoption $path -textvariable]
435                set registered 1
436            }
437            DynamicHelp::register $menu menuentry $count $desc
438        }
439
440        # entry accelerator
441        set accel [_parse_accelerator [lindex $entry 4]]
442        if { [llength $accel] } {
443            lappend opt -accelerator [lindex $accel 0]
444            bind $_widget($path,top) [lindex $accel 1] "$menu invoke $count"
445        }
446
447        # user options
448        set useropt [lrange $entry 5 end]
449        if { ![string compare $type "command"] || 
450             ![string compare $type "radiobutton"] ||
451             ![string compare $type "checkbutton"] } {
452            eval $menu add $type $opt $useropt
453        } else {
454            return -code error "invalid menu type \"$type\""
455        }
456        incr count
457    }
458}
459
460
461# ------------------------------------------------------------------------------
462#  Command MainFrame::_parse_name
463# ------------------------------------------------------------------------------
464proc MainFrame::_parse_name { menuname } {
465    set idx [string first "&" $menuname]
466    if { $idx == -1 } {
467        return [list -label $menuname]
468    } else {
469        set beg [string range $menuname 0 [expr $idx-1]]
470        set end [string range $menuname [expr $idx+1] end]
471        append beg $end
472        return [list -label $beg -underline $idx]
473    }
474}
475
476
477# ------------------------------------------------------------------------------
478#  Command MainFrame::_parse_accelerator
479# ------------------------------------------------------------------------------
480proc MainFrame::_parse_accelerator { desc } {
481    if { [llength $desc] == 2 } {
482        set seq [lindex $desc 0]
483        set key [lindex $desc 1]
484        switch -- $seq {
485            Ctrl {
486                set accel "Ctrl+[string toupper $key]"
487                set event "<Control-Key-[string tolower $key]>"
488            }
489            Alt {
490                set accel "Atl+[string toupper $key]"
491                set event "<Alt-Key-[string tolower $key]>"
492            }
493            CtrlAlt {
494                set accel "Ctrl+Alt+[string toupper $key]"
495                set event "<Control-Alt-Key-[string tolower $key]>"
496            }
497            default {
498                return -code error "invalid accelerator code $seq"
499            }
500        }
501        return [list $accel $event]
502    }
503    return {}
504}
505
506
Note: See TracBrowser for help on using the repository browser.