1 # ui-pagelist.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1996-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30
31 import WidgetClass
32 if {$tcl_platform(platform)=="windows"} {
33 WidgetClass transparent_gif SystemButtonFace
34 }
35 import Observer DropDown/Text
36
37 # A set of widgets for mb pages.
38 # Call <tt>config_widgets</tt> with a list of widgets you want to be included.
39 #
40 Class MBPageNavPanel -superclass {MBWidget Observer}
41
42 # constructor <br>
43 # <u>parent</u>: parent widget
44 #
45 MBPageNavPanel public init {parent pageMgr} {
46 $self set pageMgr_ $pageMgr
47 $self set path_ [frame $parent.pgnavpanel]
48 $pageMgr attach_observer $self
49 }
50
51 # observer call back from pageMgr
52 MBPageNavPanel private switch_page {page_id} {
53 $self instvar pageList_ zoom_
54 if [info exists pageList_] {
55 $pageList_ switch_page $page_id
56 }
57 if [info exists zoom_] {
58 # update after idle so that the configure event which
59 # updates the new canvas scale value gets called first
60 after idle "$self update_zoomscale"
61 }
62 }
63
64 # observer call back from pageMgr
65 MBPageNavPanel public add_page {page_id} {
66 [$self set pageList_] add_page $page_id
67 }
68
69 # <u>widget_list</u> is a list that is a subset of
70 # {pagelist prev next zoom}
71 # the widgets are build from left to right
72 MBPageNavPanel public build_widgets {widget_list} {
73 foreach wgt $widget_list {
74 $self build_$wgt
75 }
76 }
77
78 # builds the pagelist widget which is a dropdown consisting of the various
79 # pages
80 MBPageNavPanel private build_pagelist {} {
81 $self instvar path_ pageList_ pageMgr_
82 set pageList_ [new MBPageList $pageMgr_ $path_ -padx 1 -pady 1 \
83 -side left -anchor c -fill y]
84 }
85
86 # builds the previous page button
87 MBPageNavPanel private build_prev {} {
88 $self instvar path_ pageList_ prev_
89 set prev_ [button $path_.p -fg blue -bitmap back \
90 -command "$pageList_ nextPage -1"]
91 pack $prev_ -after [$pageList_ get_menubutton] \
92 -side left -anchor e -padx 1 -pady 3 -fill y
93 }
94
95 # builds the next page button
96 MBPageNavPanel private build_next {} {
97 $self instvar path_ pageList_ next_
98 set next_ [button $path_.n -fg blue -bitmap forw \
99 -command "$pageList_ nextPage 1"]
100 pack $next_ -after [$pageList_ get_menubutton] \
101 -side left -anchor e -padx 1 -pady 3 -fill y
102 }
103
104 # builds the zoom dropdown
105 MBPageNavPanel private build_zoom {} {
106 $self instvar path_ pageList_ zoom_ zoomValue_
107 $self tkvar zoomValue_
108 set zoom_ [DropDown/Text $path_.z -width 5 \
109 -var [$self tkvarname zoomValue_] -options {
110 { entry.width 15 }
111 }]
112 trace variable zoomValue_ w "$self set_zoom"
113 $zoom_ insert end "fix to view" 50% 100% 125% 150% 175% 200% \
114 "fit width" "fit height" \
115 "fit all"
116
117 pack $zoom_ -side left -anchor e -padx 1 -pady 1 -fill y
118 }
119
120 # sets zoom level, called when user presses "enter"
121 MBPageNavPanel private set_zoom {args} {
122 $self instvar zoom_ pageMgr_
123 $self tkvar zoomValue_
124 set currCanvas [$pageMgr_ current_canvas]
125 if {$currCanvas!={}} {
126 $currCanvas zoom_policy $zoomValue_
127 $self update_zoomscale
128 }
129 }
130
131 # updates the zoom scale for the current canvas
132 MBPageNavPanel public update_zoomscale {} {
133 $self instvar pageMgr_ zoom_
134 $self tkvar zoomValue_
135
136 set canv [$pageMgr_ current_canvas]
137 if {$canv!={}} {
138 if {$zoomValue_!="fix to view"} {
139 set label ""
140 } else {
141 set label "\[$zoomValue_\] "
142 }
143 # puts "scale is [$canv getscale]"
144 append label [expr {int(100*([$canv getscale]+0.005))}] "%"
145 # puts "label=$label"
146 $zoom_ configure -entryVal $label
147 }
148 }
149
150 # DropDown box with a list of pages
151 Class MBPageList
152
153 MBPageList public init {pageMgr parent args} {
154 $self next
155 $self set pageMgr_ $pageMgr
156 $self instvar menubutton_ pagelist_ menus_
157
158 set medfont [$self get_option medfont]
159 # set label [label $parent.pagelistlabel -text "Page: "]
160 set menubutton_ [menubutton $parent.pagelist -text " " \
161 -menu $parent.pagelist.menu -indicator 0 \
162 -font $medfont \
163 -relief raised -highlightthickness 2 -anchor c]
164
165 # menus can be torn off, we store all torn off menus in a list
166 # so that new pages can be updated in all.
167 lappend menus_ [menu $parent.pagelist.menu \
168 -tearoff 1 -tearoffcommand [list $self tearoff]]
169
170 # eval pack $label -side left $args
171 eval pack $menubutton_ $args
172
173 # stores the list of defined pages during the session
174 set pagelist_ {}
175 }
176
177 MBPageList public get_menubutton {} {
178 return [$self set menubutton_]
179 }
180
181 MBPageList public get_copy {parent} {
182 global tcl_version
183 if {$tcl_version >= 8} {
184 set clonemenu $parent.pagelist
185 [lindex [$self set menus_] 0] clone $clonemenu
186 return $clonemenu
187 }
188
189 # for tk version 7.4 and below
190 $self instvar menus_ pagelist_ pageMgr_
191 set medfont [$self get_option medfont]
192
193 set menu [menu $parent.pagelist -tearoff 0]
194 foreach pageid $pagelist_ {
195 $menu add radiobutton -label [$self page_label $page_id] \
196 -value $page_id -font $medfont\
197 -variable [$self tkvarname currPage_] \
198 -command "$pageMgr_ switch_page_later $page_id"
199
200 }
201 lappend menus_ $menu
202 return $menu
203 }
204
205 MBPageList public tearoff {menu newmenu} {
206 $self instvar menus_
207 lappend menus_ $newmenu
208
209 wm title $newmenu "MB Pages"
210 wm resizable $newmenu false false
211 }
212
213 # function to be called when mb changes page
214 MBPageList public switch_page {page_id} {
215 [$self set menubutton_] configure -text [$self page_label $page_id]
216 $self tkvar currPage_
217 set currPage_ $page_id
218 }
219
220 MBPageList private page_label {page_id} {
221 return [[$self set pageMgr_] page_label $page_id]
222 }
223
224 # add a new page
225 MBPageList public add_page {page_id} {
226 $self instvar menubutton_ pagelist_ menus_ labels_
227
228 # sort according to srcid, than page number
229 # page id is: addr_uid:pguid
230 set wrk [split $page_id :]
231 set host [lindex $wrk 0]
232 set puid "0x"
233 append puid [lindex $wrk 1]
234 set idx 0
235 foreach elt $pagelist_ {
236 set wrk [split $elt :]
237 if {[lindex $wrk 0] > $host} {
238 incr idx
239 continue
240 }
241 if {[lindex $wrk 0] == $host} {
242 set p "0x"
243 append p [lindex $wrk 1]
244 if {$puid > $p} {
245 incr idx
246 continue
247 }
248 }
249 break
250 }
251 # puts "pagelist_ is: $pagelist_"
252 # if [info exists elt] { puts "elt=$elt idx=$idx" }
253 set sortedlist [linsert $pagelist_ $idx $page_id]
254 # puts "new sortedlist is $sortedlist"
255 set next_idx [lindex $sortedlist [expr $idx + 1]]
256 # puts "next_idx=$next_idx"
257
258 # either append or insert before the label
259 if {$next_idx=={}} {
260 set next_idx "end"
261 } else {
262 set next_idx $labels_($next_idx)
263 }
264 set medfont [$self get_option medfont]
265
266 global tcl_version
267 # tcl version 8 and above will insert them automatically into
268 # all forked off menus...
269 if {$tcl_version < 8} {
270 set menu_list $menus_
271 } else {
272 set menu_list [lindex $menus_ 0]
273 }
274 $self instvar pageMgr_
275 foreach menu $menu_list {
276 $menu insert "$next_idx" radiobutton -label \
277 [$self page_label $page_id] \
278 -value $page_id \
279 -variable [$self tkvarname currPage_] \
280 -command "$pageMgr_ switch_page_later $page_id" \
281 -font $medfont
282 }
283 set labels_($page_id) [$self page_label $page_id]
284 if {$pagelist_==""} {
285 $menubutton_ configure -text [$self page_label $page_id]
286 set currPage_ $page_id
287 }
288 set pagelist_ $sortedlist
289 }
290
291 MBPageList instproc pagelist {} {
292 return [$self set pagelist_]
293 }
294
295 # dir is +1 or -1
296 MBPageList instproc nextPage { dir } {
297 $self instvar pagelist_ pageMgr_
298 if {$pagelist_=={}} { return }
299 set c [lsearch -exact $pagelist_ [$pageMgr_ current_page]]
300 set i $c
301 if {$i==-1} {
302 puts stderr "current page not in list! should not happen"
303 }
304 set l [llength $pagelist_]
305 #wrap around
306 incr i $dir
307 set i [ expr ($i < 0) ? ($l - 1) : (($i >= $l) ? 0 : $i) ]
308 if {$i != $c} {
309 set next_pg [lindex $pagelist_ $i]
310 mtrace trcVerbose "next_pg=$next_pg i=$i l=$l"
311 $pageMgr_ switch_page_later $next_pg
312 }
313 }
314
315 # source info has changed, update the page name to reflect it
316 MBPageList instproc update_src_info {src newcname} {
317 $self instvar labels_ menus_ pagelist_
318 # the pages are sorted according to page_ids', so when a cnames
319 # is updated, only the label of pages from the source needs to be
320 # changed.
321 foreach pageid $pagelist_ {
322 # puts "matching $pageid"
323 #set patt [join [list [$src addr-hex] "_" [format "%x" [$src
324 #uid]] "*"] ""] c
325
326 set srcid [split [$src srcid] "@"]
327 set patt [join [list [lindex $srcid 1] "_" \
328 [lindex $srcid 0] "*"] ""]
329
330 # puts "with $patt"
331 if [string match $patt $pageid] {
332 set newLabel [$self page_label $pageid]
333 # puts "match $labels_($pageid)"
334 foreach menu $menus_ {
335 $menu entryconfigure $labels_($pageid) \
336 -label $newLabel
337 }
338 set labels_($pageid) $newLabel
339 }
340 }
341 $self instvar menubutton_
342 $self tkvar currPage_
343 if [info exists currPage_] {
344 $menubutton_ configure -text [$self page_label $currPage_]
345 }
346 }
347
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.