Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | # Converted from menu.tcl -- |
2 | # | |
3 | # This file defines the default bindings for Tk menus and menubuttons. | |
4 | # It also implements keyboard traversal of menus and implements a few | |
5 | # other utility procedures related to menus. | |
6 | # | |
7 | # @(#) menu.tcl 1.34 94/12/19 17:09:09 | |
8 | # | |
9 | # Copyright (c) 1992-1994 The Regents of the University of California. | |
10 | # Copyright (c) 1994 Sun Microsystems, Inc. | |
11 | # | |
12 | # See the file "license.terms" for information on usage and redistribution | |
13 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
14 | ||
15 | package Tk::Menu; | |
16 | require Tk; | |
17 | require Tk::Widget; | |
18 | require Tk::Wm; | |
19 | require Tk::Derived; | |
20 | require Tk::Menu::Item; | |
21 | ||
22 | ||
23 | use vars qw($VERSION); | |
24 | $VERSION = '3.045'; # $Id: //depot/Tk8/Tk/Menu.pm#45 $ | |
25 | ||
26 | use strict; | |
27 | ||
28 | use base qw(Tk::Wm Tk::Derived Tk::Widget); | |
29 | ||
30 | Construct Tk::Widget 'Menu'; | |
31 | ||
32 | sub Tk_cmd { \&Tk::_menu } | |
33 | ||
34 | Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure', | |
35 | 'index','insert','invoke','post','postcascade','type', | |
36 | 'unpost','yposition'); | |
37 | ||
38 | import Tk qw(Ev); | |
39 | ||
40 | sub CreateArgs | |
41 | { | |
42 | my ($package,$parent,$args) = @_; | |
43 | # Remove from hash %$args any configure-like | |
44 | # options which only apply at create time (e.g. -class for Frame) | |
45 | # return these as a list of -key => value pairs | |
46 | my @result = (); | |
47 | my $opt; | |
48 | foreach $opt (qw(-type -screen -visual -colormap)) | |
49 | { | |
50 | my $val = delete $args->{$opt}; | |
51 | push(@result, $opt => $val) if (defined $val); | |
52 | } | |
53 | return @result; | |
54 | } | |
55 | ||
56 | sub InitObject | |
57 | { | |
58 | my ($menu,$args) = @_; | |
59 | my $menuitems = delete $args->{-menuitems}; | |
60 | $menu->SUPER::InitObject($args); | |
61 | if (defined $menuitems) | |
62 | { | |
63 | # If any other args do configure now | |
64 | if (%$args) | |
65 | { | |
66 | $menu->configure(%$args); | |
67 | %$args = (); | |
68 | } | |
69 | $menu->AddItems(@$menuitems) | |
70 | } | |
71 | } | |
72 | ||
73 | sub AddItems | |
74 | { | |
75 | my $menu = shift; | |
76 | ITEM: | |
77 | while (@_) | |
78 | { | |
79 | my $item = shift; | |
80 | if (!ref($item)) | |
81 | { | |
82 | $menu->separator; # A separator | |
83 | } | |
84 | else | |
85 | { | |
86 | my ($kind,$name,%minfo) = ( @$item ); | |
87 | my $invoke = delete $minfo{'-invoke'}; | |
88 | if (defined $name) | |
89 | { | |
90 | $minfo{-label} = $name unless defined($minfo{-label}); | |
91 | $menu->$kind(%minfo); | |
92 | } | |
93 | else | |
94 | { | |
95 | $menu->BackTrace("Don't recognize " . join(' ',@$item)); | |
96 | } | |
97 | } # A non-separator | |
98 | } | |
99 | } | |
100 | ||
101 | # | |
102 | #------------------------------------------------------------------------- | |
103 | # Elements of tkPriv that are used in this file: | |
104 | # | |
105 | # cursor - Saves the -cursor option for the posted menubutton. | |
106 | # focus - Saves the focus during a menu selection operation. | |
107 | # Focus gets restored here when the menu is unposted. | |
108 | # inMenubutton - The name of the menubutton widget containing | |
109 | # the mouse, or an empty string if the mouse is | |
110 | # not over any menubutton. | |
111 | # popup - If a menu has been popped up via tk_popup, this | |
112 | # gives the name of the menu. Otherwise this | |
113 | # value is empty. | |
114 | # postedMb - Name of the menubutton whose menu is currently | |
115 | # posted, or an empty string if nothing is posted | |
116 | # A grab is set on this widget. | |
117 | # relief - Used to save the original relief of the current | |
118 | # menubutton. | |
119 | # window - When the mouse is over a menu, this holds the | |
120 | # name of the menu; it's cleared when the mouse | |
121 | # leaves the menu. | |
122 | #------------------------------------------------------------------------- | |
123 | #------------------------------------------------------------------------- | |
124 | # Overall note: | |
125 | # This file is tricky because there are four different ways that menus | |
126 | # can be used: | |
127 | # | |
128 | # 1. As a pulldown from a menubutton. This is the most common usage. | |
129 | # In this style, the variable tkPriv(postedMb) identifies the posted | |
130 | # menubutton. | |
131 | # 2. As a torn-off menu copied from some other menu. In this style | |
132 | # tkPriv(postedMb) is empty, and the top-level menu is no | |
133 | # override-redirect. | |
134 | # 3. As an option menu, triggered from an option menubutton. In thi | |
135 | # style tkPriv(postedMb) identifies the posted menubutton. | |
136 | # 4. As a popup menu. In this style tkPriv(postedMb) is empty and | |
137 | # the top-level menu is override-redirect. | |
138 | # | |
139 | # The various binding procedures use the state described above to | |
140 | # distinguish the various cases and take different actions in each | |
141 | # case. | |
142 | #------------------------------------------------------------------------- | |
143 | # Bind -- | |
144 | # This procedure is invoked the first time the mouse enters a menubutton | |
145 | # widget or a menubutton widget receives the input focus. It creates | |
146 | # all of the class bindings for both menubuttons and menus. | |
147 | # | |
148 | # Arguments: | |
149 | # w - The widget that was just entered or just received | |
150 | # the input focus. | |
151 | # event - Indicates which event caused the procedure to be invoked | |
152 | # (Enter or FocusIn). It is used so that we can carry out | |
153 | # the functions of that event in addition to setting up | |
154 | # bindings. | |
155 | sub ClassInit | |
156 | { | |
157 | my ($class,$mw) = @_; | |
158 | # Must set focus when mouse enters a menu, in order to allow | |
159 | # mixed-mode processing using both the mouse and the keyboard. | |
160 | $mw->bind($class,'<FocusIn>', 'NoOp'); | |
161 | $mw->bind($class,'<Enter>', 'Enter'); | |
162 | $mw->bind($class,'<Leave>', ['Leave',Ev('X'),Ev('Y'),Ev('s')]); | |
163 | $mw->bind($class,'<Motion>', ['Motion',Ev('x'),Ev('y'),Ev('s')]); | |
164 | $mw->bind($class,'<ButtonPress>','ButtonDown'); | |
165 | $mw->bind($class,'<ButtonRelease>',['Invoke',1]); | |
166 | $mw->bind($class,'<space>',['Invoke',0]); | |
167 | $mw->bind($class,'<Return>',['Invoke',0]); | |
168 | $mw->bind($class,'<Escape>','Escape'); | |
169 | $mw->bind($class,'<Left>','LeftArrow'); | |
170 | $mw->bind($class,'<Right>','RightArrow'); | |
171 | $mw->bind($class,'<Up>','UpArrow'); | |
172 | $mw->bind($class,'<Down>','DownArrow'); | |
173 | $mw->bind($class,'<KeyPress>', ['TraverseWithinMenu',Ev('K')]); | |
174 | $mw->bind($class,'<Alt-KeyPress>', ['TraverseWithinMenu',Ev('K')]); | |
175 | return $class; | |
176 | } | |
177 | ||
178 | sub UpArrow | |
179 | { | |
180 | my $menu = shift; | |
181 | if ($menu->cget('-type') eq 'menubar') | |
182 | { | |
183 | $menu->NextMenu('left'); | |
184 | } | |
185 | else | |
186 | { | |
187 | $menu->NextEntry(-1); | |
188 | } | |
189 | } | |
190 | ||
191 | sub DownArrow | |
192 | { | |
193 | my $menu = shift; | |
194 | if ($menu->cget('-type') eq 'menubar') | |
195 | { | |
196 | $menu->NextMenu('right'); | |
197 | } | |
198 | else | |
199 | { | |
200 | $menu->NextEntry(1); | |
201 | } | |
202 | } | |
203 | ||
204 | sub LeftArrow | |
205 | { | |
206 | my $menu = shift; | |
207 | if ($menu->cget('-type') eq 'menubar') | |
208 | { | |
209 | $menu->NextEntry(-1); | |
210 | } | |
211 | else | |
212 | { | |
213 | $menu->NextMenu('left'); | |
214 | } | |
215 | } | |
216 | ||
217 | sub RightArrow | |
218 | { | |
219 | my $menu = shift; | |
220 | if ($menu->cget('-type') eq 'menubar') | |
221 | { | |
222 | $menu->NextEntry(1); | |
223 | } | |
224 | else | |
225 | { | |
226 | $menu->NextMenu('right'); | |
227 | } | |
228 | } | |
229 | ||
230 | ||
231 | ||
232 | # Unpost -- | |
233 | # This procedure unposts a given menu, plus all of its ancestors up | |
234 | # to (and including) a menubutton, if any. It also restores various | |
235 | # values to what they were before the menu was posted, and releases | |
236 | # a grab if there's a menubutton involved. Special notes: | |
237 | # 1. It's important to unpost all menus before releasing the grab, so | |
238 | # that any Enter-Leave events (e.g. from menu back to main | |
239 | # application) have mode NotifyGrab. | |
240 | # 2. Be sure to enclose various groups of commands in "catch" so that | |
241 | # the procedure will complete even if the menubutton or the menu | |
242 | # or the grab window has been deleted. | |
243 | # | |
244 | # Arguments: | |
245 | # menu - Name of a menu to unpost. Ignored if there | |
246 | # is a posted menubutton. | |
247 | sub Unpost | |
248 | { | |
249 | my $menu = shift; | |
250 | my $mb = $Tk::postedMb; | |
251 | ||
252 | # Restore focus right away (otherwise X will take focus away when | |
253 | # the menu is unmapped and under some window managers (e.g. olvwm) | |
254 | # we'll lose the focus completely). | |
255 | ||
256 | eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus); | |
257 | undef $Tk::focus; | |
258 | ||
259 | # Unpost menu(s) and restore some stuff that's dependent on | |
260 | # what was posted. | |
261 | eval {local $SIG{__DIE__}; | |
262 | if (defined $mb) | |
263 | { | |
264 | $menu = $mb->cget('-menu'); | |
265 | $menu->unpost(); | |
266 | $Tk::postedMb = undef; | |
267 | $mb->configure('-cursor',$Tk::cursor); | |
268 | $mb->configure('-relief',$Tk::relief) | |
269 | } | |
270 | elsif (defined $Tk::popup) | |
271 | { | |
272 | $Tk::popup->unpost(); | |
273 | my $grab = $Tk::popup->grabCurrent; | |
274 | $grab->grabRelease if (defined $grab); | |
275 | ||
276 | undef $Tk::popup; | |
277 | } | |
278 | elsif (defined $menu && ref $menu && | |
279 | $menu->cget('-type') ne 'menubar' && | |
280 | $menu->cget('-type') ne 'tearoff' | |
281 | ) | |
282 | { | |
283 | # We're in a cascaded sub-menu from a torn-off menu or popup. | |
284 | # Unpost all the menus up to the toplevel one (but not | |
285 | # including the top-level torn-off one) and deactivate the | |
286 | # top-level torn off menu if there is one. | |
287 | while (1) | |
288 | { | |
289 | my $parent = $menu->parent; | |
290 | last if (!$parent->IsMenu || !$parent->ismapped); | |
291 | $parent->postcascade('none'); | |
292 | $parent->GenerateMenuSelect; | |
293 | $parent->activate('none'); | |
294 | my $type = $parent->cget('-type'); | |
295 | last if ($type eq 'menubar' || $type eq 'tearoff'); | |
296 | $menu = $parent | |
297 | } | |
298 | $menu->unpost() if ($menu->cget('-type') ne 'menubar'); | |
299 | } | |
300 | }; | |
301 | warn "$@" if ($@); | |
302 | if ($Tk::tearoff || $Tk::menubar) | |
303 | { | |
304 | # Release grab, if any. | |
305 | if (defined $menu && ref $menu) | |
306 | { | |
307 | my $grab = $menu->grabCurrent; | |
308 | $grab->grabRelease if (defined $grab); | |
309 | } | |
310 | RestoreOldGrab(); | |
311 | if ($Tk::menubar) | |
312 | { | |
313 | $Tk::menubar->configure(-cursor => $Tk::cursor); | |
314 | undef $Tk::menubar; | |
315 | } | |
316 | if ($Tk::platform ne 'unix') | |
317 | { | |
318 | undef $Tk::tearoff; | |
319 | } | |
320 | } | |
321 | } | |
322 | ||
323 | sub RestoreOldGrab | |
324 | { | |
325 | if (defined $Tk::oldGrab) | |
326 | { | |
327 | eval | |
328 | { | |
329 | local $SIG{__DIE__}; | |
330 | if ($Tk::grabStatus eq 'global') | |
331 | { | |
332 | $Tk::oldGrab->grabGlobal; | |
333 | } | |
334 | else | |
335 | { | |
336 | $Tk::oldGrab->grab; | |
337 | } | |
338 | }; | |
339 | undef $Tk::oldGrab; | |
340 | } | |
341 | } | |
342 | ||
343 | sub typeIS | |
344 | {my $w = shift; | |
345 | my $type = $w->type(shift); | |
346 | return defined $type && $type eq shift; | |
347 | } | |
348 | ||
349 | # Motion -- | |
350 | # This procedure is called to handle mouse motion events for menus. | |
351 | # It does two things. First, it resets the active element in the | |
352 | # menu, if the mouse is over the menu. Second, if a mouse button | |
353 | # is down, it posts and unposts cascade entries to match the mouse | |
354 | # position. | |
355 | # | |
356 | # Arguments: | |
357 | # menu - The menu window. | |
358 | # y - The y position of the mouse. | |
359 | # state - Modifier state (tells whether buttons are down). | |
360 | sub Motion | |
361 | { | |
362 | my $menu = shift; | |
363 | my $x = shift; | |
364 | my $y = shift; | |
365 | my $state = shift; | |
366 | my $t = $menu->cget('-type'); | |
367 | ||
368 | if ($menu->IS($Tk::window)) | |
369 | { | |
370 | if ($menu->cget('-type') eq 'menubar') | |
371 | { | |
372 | # if (defined($Tk::focus) && $Tk::focus != $menu) | |
373 | { | |
374 | $menu->activate("\@$x,$y"); | |
375 | $menu->GenerateMenuSelect; | |
376 | } | |
377 | } | |
378 | else | |
379 | { | |
380 | $menu->activate("\@$x,$y"); | |
381 | $menu->GenerateMenuSelect; | |
382 | } | |
383 | } | |
384 | if (($state & 0x1f00) != 0) | |
385 | { | |
386 | $menu->postcascade('active') | |
387 | } | |
388 | } | |
389 | # ButtonDown -- | |
390 | # Handles button presses in menus. There are a couple of tricky things | |
391 | # here: | |
392 | # 1. Change the posted cascade entry (if any) to match the mouse position. | |
393 | # 2. If there is a posted menubutton, must grab to the menubutton so | |
394 | # that it can track mouse motions over other menubuttons and change | |
395 | # the posted menu. | |
396 | # 3. If there's no posted menubutton (e.g. because we're a torn-off menu | |
397 | # or one of its descendants) must grab to the top-level menu so that | |
398 | # we can track mouse motions across the entire menu hierarchy. | |
399 | ||
400 | # | |
401 | # Arguments: | |
402 | # menu - The menu window. | |
403 | sub ButtonDown | |
404 | { | |
405 | my $menu = shift; | |
406 | $menu->postcascade('active'); | |
407 | if (defined $Tk::postedMb) | |
408 | { | |
409 | $Tk::postedMb->grabGlobal | |
410 | } | |
411 | else | |
412 | { | |
413 | while ($menu->cget('-type') eq 'normal' | |
414 | && $menu->parent->IsMenu | |
415 | && $menu->parent->ismapped | |
416 | ) | |
417 | { | |
418 | $menu = $menu->parent; | |
419 | } | |
420 | ||
421 | if (!defined $Tk::menuBar) | |
422 | { | |
423 | $Tk::menuBar = $menu; | |
424 | $Tk::cursor = $menu->cget('-cursor'); | |
425 | $menu->configure(-cursor => 'arrow'); | |
426 | } | |
427 | ||
428 | # Don't update grab information if the grab window isn't changing. | |
429 | # Otherwise, we'll get an error when we unpost the menus and | |
430 | # restore the grab, since the old grab window will not be viewable | |
431 | # anymore. | |
432 | ||
433 | $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent)); | |
434 | ||
435 | # Must re-grab even if the grab window hasn't changed, in order | |
436 | # to release the implicit grab from the button press. | |
437 | ||
438 | $menu->grabGlobal if ($Tk::platform eq 'unix'); | |
439 | } | |
440 | } | |
441 | ||
442 | sub Enter | |
443 | { | |
444 | my $w = shift; | |
445 | my $ev = $w->XEvent; | |
446 | $Tk::window = $w; | |
447 | if ($w->cget('-type') eq 'tearoff') | |
448 | { | |
449 | if ($ev->m ne 'NotifyUngrab') | |
450 | { | |
451 | $w->SetFocus if ($Tk::platform eq 'unix'); | |
452 | } | |
453 | } | |
454 | $w->Motion($ev->x, $ev->y, $ev->s); | |
455 | } | |
456 | ||
457 | # Leave -- | |
458 | # This procedure is invoked to handle Leave events for a menu. It | |
459 | # deactivates everything unless the active element is a cascade element | |
460 | # and the mouse is now over the submenu. | |
461 | # | |
462 | # Arguments: | |
463 | # menu - The menu window. | |
464 | # rootx, rooty - Root coordinates of mouse. | |
465 | # state - Modifier state. | |
466 | sub Leave | |
467 | { | |
468 | my $menu = shift; | |
469 | my $rootx = shift; | |
470 | my $rooty = shift; | |
471 | my $state = shift; | |
472 | undef $Tk::window; | |
473 | return if ($menu->index('active') eq 'none'); | |
474 | if ($menu->typeIS('active','cascade')) | |
475 | { | |
476 | my $c = $menu->Containing($rootx,$rooty); | |
477 | return if (defined $c && $menu->entrycget('active','-menu')->IS($c)); | |
478 | } | |
479 | $menu->activate('none'); | |
480 | $menu->GenerateMenuSelect; | |
481 | } | |
482 | ||
483 | # Invoke -- | |
484 | # This procedure is invoked when button 1 is released over a menu. | |
485 | # It invokes the appropriate menu action and unposts the menu if | |
486 | # it came from a menubutton. | |
487 | # | |
488 | # Arguments: | |
489 | # w - Name of the menu widget. | |
490 | sub Invoke | |
491 | { | |
492 | my $w = shift; | |
493 | my $release = shift; | |
494 | ||
495 | if ($release && !defined($Tk::window)) | |
496 | { | |
497 | # Mouse was pressed over a menu without a menu button, then | |
498 | # dragged off the menu (possibly with a cascade posted) and | |
499 | # released. Unpost everything and quit. | |
500 | ||
501 | $w->postcascade('none'); | |
502 | $w->activate('none'); | |
503 | $w->eventGenerate('<<MenuSelect>>'); | |
504 | $w->Unpost; | |
505 | return; | |
506 | } | |
507 | ||
508 | my $type = $w->type('active'); | |
509 | if ($w->typeIS('active','cascade')) | |
510 | { | |
511 | $w->postcascade('active'); | |
512 | my $menu = $w->entrycget('active','-menu'); | |
513 | $menu->FirstEntry() if (defined $menu); | |
514 | } | |
515 | elsif ($w->typeIS('active','tearoff')) | |
516 | { | |
517 | $w->Unpost(); | |
518 | $w->tearOffMenu(); | |
519 | } | |
520 | elsif ($w->typeIS('active','menubar')) | |
521 | { | |
522 | $w->postcascade('none'); | |
523 | $w->activate('none'); | |
524 | $w->eventGenerate('<<MenuSelect>>'); | |
525 | $w->Unpost; | |
526 | } | |
527 | else | |
528 | { | |
529 | $w->Unpost(); | |
530 | $w->invoke('active') | |
531 | } | |
532 | } | |
533 | # Escape -- | |
534 | # This procedure is invoked for the Cancel (or Escape) key. It unposts | |
535 | # the given menu and, if it is the top-level menu for a menu button, | |
536 | # unposts the menu button as well. | |
537 | # | |
538 | # Arguments: | |
539 | # menu - Name of the menu window. | |
540 | sub Escape | |
541 | { | |
542 | my $menu = shift; | |
543 | my $parent = $menu->parent; | |
544 | if (!$parent->IsMenu) | |
545 | { | |
546 | $menu->Unpost() | |
547 | } | |
548 | elsif ($parent->cget('-type') eq 'menubar') | |
549 | { | |
550 | $menu->Unpost; | |
551 | RestoreOldGrab(); | |
552 | } | |
553 | else | |
554 | { | |
555 | $menu->NextMenu(-1) | |
556 | } | |
557 | } | |
558 | # LeftRight -- | |
559 | # This procedure is invoked to handle "left" and "right" traversal | |
560 | # motions in menus. It traverses to the next menu in a menu bar, | |
561 | # or into or out of a cascaded menu. | |
562 | # | |
563 | # Arguments: | |
564 | # menu - The menu that received the keyboard | |
565 | # event. | |
566 | # direction - Direction in which to move: "left" or "right" | |
567 | sub NextMenu | |
568 | { | |
569 | my $menu = shift; | |
570 | my $direction = shift; | |
571 | # First handle traversals into and out of cascaded menus. | |
572 | my $count; | |
573 | if ($direction eq 'right') | |
574 | { | |
575 | $count = 1; | |
576 | if ($menu->typeIS('active','cascade')) | |
577 | { | |
578 | $menu->postcascade('active'); | |
579 | my $m2 = $menu->entrycget('active','-menu'); | |
580 | $m2->FirstEntry if (defined $m2); | |
581 | return; | |
582 | } | |
583 | else | |
584 | { | |
585 | my $parent = $menu->parent; | |
586 | while ($parent->PathName ne '.') | |
587 | { | |
588 | if ($parent->IsMenu && $parent->cget('-type') eq 'menubar') | |
589 | { | |
590 | $parent->SetFocus; | |
591 | $parent->NextEntry(1); | |
592 | return; | |
593 | } | |
594 | $parent = $parent->parent; | |
595 | } | |
596 | } | |
597 | } | |
598 | else | |
599 | { | |
600 | $count = -1; | |
601 | my $m2 = $menu->parent; | |
602 | if ($m2->IsMenu) | |
603 | { | |
604 | if ($m2->cget('-type') ne 'menubar') | |
605 | { | |
606 | $menu->activate('none'); | |
607 | $menu->GenerateMenuSelect; | |
608 | $m2->SetFocus; | |
609 | # This code unposts any posted submenu in the parent. | |
610 | my $tmp = $m2->index('active'); | |
611 | $m2->activate('none'); | |
612 | $m2->activate($tmp); | |
613 | return; | |
614 | } | |
615 | } | |
616 | } | |
617 | # Can't traverse into or out of a cascaded menu. Go to the next | |
618 | # or previous menubutton, if that makes sense. | |
619 | ||
620 | my $m2 = $menu->parent; | |
621 | if ($m2->IsMenu) | |
622 | { | |
623 | if ($m2->cget('-type') eq 'menubar') | |
624 | { | |
625 | $m2->SetFocus; | |
626 | $m2->NextEntry(-1); | |
627 | return; | |
628 | } | |
629 | } | |
630 | ||
631 | my $w = $Tk::postedMb; | |
632 | return unless defined $w; | |
633 | my @buttons = $w->parent->children; | |
634 | my $length = @buttons; | |
635 | my $i = Tk::lsearch(\@buttons,$w)+$count; | |
636 | my $mb; | |
637 | while (1) | |
638 | { | |
639 | while ($i < 0) | |
640 | { | |
641 | $i += $length | |
642 | } | |
643 | while ($i >= $length) | |
644 | { | |
645 | $i += -$length | |
646 | } | |
647 | $mb = $buttons[$i]; | |
648 | last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled' | |
649 | && defined($mb->cget('-menu')) | |
650 | && $mb->cget('-menu')->index('last') ne 'none' | |
651 | ); | |
652 | return if ($mb == $w); | |
653 | $i += $count | |
654 | } | |
655 | $mb->PostFirst(); | |
656 | } | |
657 | # NextEntry -- | |
658 | # Activate the next higher or lower entry in the posted menu, | |
659 | # wrapping around at the ends. Disabled entries are skipped. | |
660 | # | |
661 | # Arguments: | |
662 | # menu - Menu window that received the keystroke. | |
663 | # count - 1 means go to the next lower entry, | |
664 | # -1 means go to the next higher entry. | |
665 | sub NextEntry | |
666 | { | |
667 | my $menu = shift; | |
668 | my $count = shift; | |
669 | if ($menu->index('last') eq 'none') | |
670 | { | |
671 | return; | |
672 | } | |
673 | my $length = $menu->index('last')+1; | |
674 | my $quitAfter = $length; | |
675 | my $active = $menu->index('active'); | |
676 | my $i = ($active eq 'none') ? 0 : $active+$count; | |
677 | while (1) | |
678 | { | |
679 | return if ($quitAfter <= 0); | |
680 | while ($i < 0) | |
681 | { | |
682 | $i += $length | |
683 | } | |
684 | while ($i >= $length) | |
685 | { | |
686 | $i += -$length | |
687 | } | |
688 | my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; | |
689 | last if (defined($state) && $state ne 'disabled'); | |
690 | return if ($i == $active); | |
691 | $i += $count; | |
692 | $quitAfter -= 1; | |
693 | } | |
694 | $menu->activate($i); | |
695 | $menu->GenerateMenuSelect; | |
696 | if ($menu->type($i) eq 'cascade') | |
697 | { | |
698 | my $cascade = $menu->entrycget($i, '-menu'); | |
699 | $menu->postcascade($i); | |
700 | $cascade->FirstEntry if (defined $cascade); | |
701 | } | |
702 | } | |
703 | ||
704 | ||
705 | # tkTraverseWithinMenu | |
706 | # This procedure implements keyboard traversal within a menu. It | |
707 | # searches for an entry in the menu that has "char" underlined. If | |
708 | # such an entry is found, it is invoked and the menu is unposted. | |
709 | # | |
710 | # Arguments: | |
711 | # w - The name of the menu widget. | |
712 | # char - The character to look for; case is | |
713 | # ignored. If the string is empty then | |
714 | # nothing happens. | |
715 | sub TraverseWithinMenu | |
716 | { | |
717 | my $w = shift; | |
718 | my $char = shift; | |
719 | return unless (defined $char); | |
720 | $char = "\L$char"; | |
721 | my $last = $w->index('last'); | |
722 | return if ($last eq 'none'); | |
723 | for (my $i = 0;$i <= $last;$i += 1) | |
724 | { | |
725 | my $label = eval {local $SIG{__DIE__}; $w->entrycget($i,'-label') }; | |
726 | next unless defined($label); | |
727 | my $ul = $w->entrycget($i,'-underline'); | |
728 | if (defined $ul && $ul >= 0) | |
729 | { | |
730 | $label = substr("\L$label",$ul,1); | |
731 | if (defined($label) && $label eq $char) | |
732 | { | |
733 | if ($w->type($i) eq 'cascade') | |
734 | { | |
735 | $w->postcascade($i); | |
736 | $w->activate($i); | |
737 | my $m2 = $w->entrycget($i,'-menu'); | |
738 | $m2->FirstEntry if (defined $m2); | |
739 | } | |
740 | else | |
741 | { | |
742 | $w->Unpost(); | |
743 | $w->invoke($i); | |
744 | } | |
745 | return; | |
746 | } | |
747 | } | |
748 | } | |
749 | } | |
750 | ||
751 | sub FindMenu | |
752 | { | |
753 | my ($menu,$char) = @_; | |
754 | if ($menu->cget('-type') eq 'menubar') | |
755 | { | |
756 | if (!defined($char) || $char eq '') | |
757 | { | |
758 | $menu->FirstEntry; | |
759 | } | |
760 | else | |
761 | { | |
762 | $menu->TraverseWithinMenu($char); | |
763 | } | |
764 | return $menu; | |
765 | } | |
766 | return undef; | |
767 | } | |
768 | ||
769 | ||
770 | # FirstEntry -- | |
771 | # Given a menu, this procedure finds the first entry that isn't | |
772 | # disabled or a tear-off or separator, and activates that entry. | |
773 | # However, if there is already an active entry in the menu (e.g., | |
774 | # because of a previous call to tkPostOverPoint) then the active | |
775 | # entry isn't changed. This procedure also sets the input focus | |
776 | # to the menu. | |
777 | # | |
778 | # Arguments: | |
779 | # menu - Name of the menu window (possibly empty). | |
780 | sub FirstEntry | |
781 | { | |
782 | my $menu = shift; | |
783 | return if (!defined($menu) || $menu eq '' || !ref($menu)); | |
784 | $menu->SetFocus; | |
785 | return if ($menu->index('active') ne 'none'); | |
786 | my $last = $menu->index('last'); | |
787 | return if ($last eq 'none'); | |
788 | for (my $i = 0;$i <= $last;$i += 1) | |
789 | { | |
790 | my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; | |
791 | if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff')) | |
792 | { | |
793 | $menu->activate($i); | |
794 | $menu->GenerateMenuSelect; | |
795 | if ($menu->type($i) eq 'cascade') | |
796 | { | |
797 | my $cascade = $menu->entrycget($i,'-menu'); | |
798 | if (defined $cascade) | |
799 | { | |
800 | $menu->postcascade($i); | |
801 | $cascade->FirstEntry; | |
802 | } | |
803 | } | |
804 | return; | |
805 | } | |
806 | } | |
807 | } | |
808 | ||
809 | # FindName -- | |
810 | # Given a menu and a text string, return the index of the menu entry | |
811 | # that displays the string as its label. If there is no such entry, | |
812 | # return an empty string. This procedure is tricky because some names | |
813 | # like "active" have a special meaning in menu commands, so we can't | |
814 | # always use the "index" widget command. | |
815 | # | |
816 | # Arguments: | |
817 | # menu - Name of the menu widget. | |
818 | # s - String to look for. | |
819 | sub FindName | |
820 | { | |
821 | my $menu = shift; | |
822 | my $s = shift; | |
823 | my $i = undef; | |
824 | if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/) | |
825 | { | |
826 | $i = eval {local $SIG{__DIE__}; $menu->index($s) }; | |
827 | return $i; | |
828 | } | |
829 | my $last = $menu->index('last'); | |
830 | return if ($last eq 'none'); | |
831 | for ($i = 0;$i <= $last;$i += 1) | |
832 | { | |
833 | my $label = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-label') }; | |
834 | return $i if (defined $label && $label eq $s); | |
835 | } | |
836 | return undef; | |
837 | } | |
838 | # PostOverPoint -- | |
839 | # This procedure posts a given menu such that a given entry in the | |
840 | # menu is centered over a given point in the root window. It also | |
841 | # activates the given entry. | |
842 | # | |
843 | # Arguments: | |
844 | # menu - Menu to post. | |
845 | # x, y - Root coordinates of point. | |
846 | # entry - Index of entry within menu to center over (x,y). | |
847 | # If omitted or specified as {}, then the menu's | |
848 | # upper-left corner goes at (x,y). | |
849 | sub PostOverPoint | |
850 | { | |
851 | my $menu = shift; | |
852 | my $x = shift; | |
853 | my $y = shift; | |
854 | my $entry = shift; | |
855 | if (defined $entry) | |
856 | { | |
857 | if ($entry == $menu->index('last')) | |
858 | { | |
859 | $y -= ($menu->yposition($entry)+$menu->height)/2; | |
860 | } | |
861 | else | |
862 | { | |
863 | $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2; | |
864 | } | |
865 | $x -= $menu->reqwidth/2; | |
866 | } | |
867 | $menu->post($x,$y); | |
868 | if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled') | |
869 | { | |
870 | $menu->activate($entry); | |
871 | $menu->GenerateMenuSelect; | |
872 | } | |
873 | } | |
874 | # tk_popup -- | |
875 | # This procedure pops up a menu and sets things up for traversing | |
876 | # the menu and its submenus. | |
877 | # | |
878 | # Arguments: | |
879 | # menu - Name of the menu to be popped up. | |
880 | # x, y - Root coordinates at which to pop up the | |
881 | # menu. | |
882 | # entry - Index of a menu entry to center over (x,y). | |
883 | # If omitted or specified as {}, then menu's | |
884 | # upper-left corner goes at (x,y). | |
885 | sub Post | |
886 | { | |
887 | my $menu = shift; | |
888 | return unless (defined $menu); | |
889 | my $x = shift; | |
890 | my $y = shift; | |
891 | my $entry = shift; | |
892 | Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb)); | |
893 | $menu->PostOverPoint($x,$y,$entry); | |
894 | $menu->grabGlobal; | |
895 | $Tk::popup = $menu; | |
896 | $Tk::focus = $menu->focusCurrent; | |
897 | $menu->focus(); | |
898 | } | |
899 | ||
900 | sub SetFocus | |
901 | { | |
902 | my $menu = shift; | |
903 | $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus)); | |
904 | $menu->focus; | |
905 | } | |
906 | ||
907 | sub GenerateMenuSelect | |
908 | { | |
909 | my $menu = shift; | |
910 | $Tk::activeMenu = $menu; | |
911 | $Tk::activeItem = $menu->index('active'); | |
912 | $menu->eventGenerate('<<MenuSelect>>'); # FIXME | |
913 | } | |
914 | ||
915 | # Converted from tearoff.tcl -- | |
916 | # | |
917 | # This file contains procedures that implement tear-off menus. | |
918 | # | |
919 | # @(#) tearoff.tcl 1.3 94/12/17 16:05:25 | |
920 | # | |
921 | # Copyright (c) 1994 The Regents of the University of California. | |
922 | # Copyright (c) 1994 Sun Microsystems, Inc. | |
923 | # | |
924 | # See the file "license.terms" for information on usage and redistribution | |
925 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
926 | # | |
927 | # tkTearoffMenu -- | |
928 | # Given the name of a menu, this procedure creates a torn-off menu | |
929 | # that is identical to the given menu (including nested submenus). | |
930 | # The new torn-off menu exists as a toplevel window managed by the | |
931 | # window manager. The return value is the name of the new menu. | |
932 | # | |
933 | # Arguments: | |
934 | # w - The menu to be torn-off (duplicated). | |
935 | sub tearOffMenu | |
936 | { | |
937 | my $w = shift; | |
938 | my $x = (@_) ? shift : 0; | |
939 | my $y = (@_) ? shift : 0; | |
940 | ||
941 | $x = $w->rootx if $x == 0; | |
942 | $y = $w->rooty if $y == 0; | |
943 | ||
944 | # Find a unique name to use for the torn-off menu. Find the first | |
945 | # ancestor of w that is a toplevel but not a menu, and use this as | |
946 | # the parent of the new menu. This guarantees that the torn off | |
947 | # menu will be on the same screen as the original menu. By making | |
948 | # it a child of the ancestor, rather than a child of the menu, it | |
949 | # can continue to live even if the menu is deleted; it will go | |
950 | # away when the toplevel goes away. | |
951 | ||
952 | my $parent = $w->parent; | |
953 | while ($parent->toplevel != $parent || $parent->IsMenu) | |
954 | { | |
955 | $parent = $parent->parent; | |
956 | } | |
957 | my $menu = $w->clone($parent,'tearoff'); | |
958 | ||
959 | # Pick a title for the new menu by looking at the parent of the | |
960 | # original: if the parent is a menu, then use the text of the active | |
961 | # entry. If it's a menubutton then use its text. | |
962 | my $title = $menu->cget('-title'); | |
963 | unless (defined $title && length($title)) | |
964 | { | |
965 | $parent = $w->parent; | |
966 | if ($parent->IsMenubutton) | |
967 | { | |
968 | $title = $parent->cget('-text'); | |
969 | } | |
970 | elsif ($parent->IsMenu) | |
971 | { | |
972 | $title = $parent->entrycget('active','-label'); | |
973 | } | |
974 | } | |
975 | $menu->title($title) if (defined $title && length($title)); | |
976 | $menu->post($x,$y); | |
977 | # Set tkPriv(focus) on entry: otherwise the focus will get lost | |
978 | # after keyboard invocation of a sub-menu (it will stay on the | |
979 | # submenu). | |
980 | $menu->bind('<Enter>','EnterFocus'); | |
981 | $menu->Callback('-tearoffcommand'); | |
982 | return $menu; | |
983 | } | |
984 | ||
985 | # tkMenuDup -- | |
986 | # Given a menu (hierarchy), create a duplicate menu (hierarchy) | |
987 | # in a given window. | |
988 | # | |
989 | # Arguments: | |
990 | # src - Source window. Must be a menu. It and its | |
991 | # menu descendants will be duplicated at dst. | |
992 | # dst - Name to use for topmost menu in duplicate | |
993 | # hierarchy. | |
994 | sub MenuDup | |
995 | { | |
996 | my $src = shift; | |
997 | my $parent = shift; | |
998 | my $type = (@_) ? shift : 'normal'; | |
999 | my %args = (-type => $type) ; | |
1000 | foreach my $option ($src->configure()) | |
1001 | { | |
1002 | next if (@$option == 2); | |
1003 | $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]}; | |
1004 | } | |
1005 | my $dst = ref($src)->new($parent,%args); | |
1006 | if ($type eq 'tearoff') | |
1007 | { | |
1008 | $dst->transient($parent->MainWindow); | |
1009 | } | |
1010 | my $last = $src->index('last'); | |
1011 | if ($last ne 'none') | |
1012 | { | |
1013 | for (my $i = $src->cget('-tearoff'); $i <= $last; $i++) | |
1014 | { | |
1015 | my $type = $src->type($i); | |
1016 | if (defined $type) | |
1017 | { | |
1018 | my @args = (); | |
1019 | foreach my $option ($src->entryconfigure($i)) | |
1020 | { | |
1021 | next if (@$option == 2); | |
1022 | push(@args,$$option[0],$$option[4]) if (defined $$option[4]); | |
1023 | } | |
1024 | $dst->add($type,@args); | |
1025 | } | |
1026 | } | |
1027 | } | |
1028 | # Duplicate the binding tags and bindings from the source menu. | |
1029 | my @bindtags = $src->bindtags; | |
1030 | my $path = $src->PathName; | |
1031 | foreach (@bindtags) | |
1032 | { | |
1033 | $_ = $dst if ($_ eq $path); | |
1034 | } | |
1035 | $dst->bindtags([@bindtags]); | |
1036 | foreach my $event ($src->bind) | |
1037 | { | |
1038 | my $cb = $src->bind($event); | |
1039 | $dst->bind($event,$cb->Substitute($src,$dst)); | |
1040 | } | |
1041 | return $dst; | |
1042 | } | |
1043 | ||
1044 | ||
1045 | ||
1046 | # Some convenience methods | |
1047 | ||
1048 | sub separator { require Tk::Menu::Item; shift->Separator(@_); } | |
1049 | sub cascade { require Tk::Menu::Item; shift->Cascade(@_); } | |
1050 | sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); } | |
1051 | sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); } | |
1052 | ||
1053 | sub command | |
1054 | { | |
1055 | my ($menu,%args) = @_; | |
1056 | require Tk::Menu::Item; | |
1057 | if (exists $args{-button}) | |
1058 | { | |
1059 | # Backward compatible stuff from 'Menubar' | |
1060 | my $button = delete $args{-button}; | |
1061 | $button = ['Misc', -underline => 0 ] unless (defined $button); | |
1062 | my @bargs = (); | |
1063 | ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY'); | |
1064 | $menu = $menu->Menubutton(-label => $button, @bargs); | |
1065 | } | |
1066 | $menu->Command(%args); | |
1067 | } | |
1068 | ||
1069 | sub Menubutton | |
1070 | { | |
1071 | my ($menu,%args) = @_; | |
1072 | my $name = delete($args{'-text'}) || $args{'-label'};; | |
1073 | $args{'-label'} = $name if (defined $name); | |
1074 | my $items = delete $args{'-menuitems'}; | |
1075 | foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill)) | |
1076 | { | |
1077 | delete $args{$opt}; | |
1078 | } | |
1079 | if (defined($name) && !defined($args{-underline})) | |
1080 | { | |
1081 | my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef; | |
1082 | if (defined($underline) && ($underline >= 0)) | |
1083 | { | |
1084 | $args{-underline} = $underline; | |
1085 | $args{-label} = $name; | |
1086 | } | |
1087 | } | |
1088 | my $hash = $menu->TkHash('MenuButtons'); | |
1089 | my $mb = $hash->{$name}; | |
1090 | if (defined $mb) | |
1091 | { | |
1092 | delete $args{'-tearoff'}; # too late! | |
1093 | $mb->configure(%args) if %args; | |
1094 | } | |
1095 | else | |
1096 | { | |
1097 | $mb = $menu->cascade(%args); | |
1098 | $hash->{$name} = $mb; | |
1099 | } | |
1100 | $mb->menu->AddItems(@$items) if defined($items) && @$items; | |
1101 | return $mb; | |
1102 | } | |
1103 | ||
1104 | sub BalloonInfo | |
1105 | { | |
1106 | my ($menu,$balloon,$X,$Y,@opt) = @_; | |
1107 | my $i = $menu->index('active'); | |
1108 | if ($i eq 'none') | |
1109 | { | |
1110 | my $y = $Y - $menu->rooty; | |
1111 | $i = $menu->index("\@$y"); | |
1112 | } | |
1113 | foreach my $opt (@opt) | |
1114 | { | |
1115 | my $info = $balloon->GetOption($opt,$menu); | |
1116 | if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) | |
1117 | { | |
1118 | $balloon->Subclient($i); | |
1119 | return '' if $i eq 'none'; | |
1120 | return ${$info}[$i] || ''; | |
1121 | } | |
1122 | return $info; | |
1123 | } | |
1124 | } | |
1125 | ||
1126 | 1; | |
1127 | ||
1128 | __END__ | |
1129 | ||
1130 |