# Converted from menu.tcl -- # # This file defines the default bindings for Tk menus and menubuttons. # It also implements keyboard traversal of menus and implements a few # other utility procedures related to menus. # # @(#) menu.tcl 1.34 94/12/19 17:09:09 # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package Tk::Menu; require Tk; require Tk::Widget; require Tk::Wm; require Tk::Derived; require Tk::Menu::Item; use vars qw($VERSION); $VERSION = sprintf '4.%03d', q$Revision: #21 $ =~ /\D(\d+)\s*$/; use strict; use base qw(Tk::Wm Tk::Derived Tk::Widget); Construct Tk::Widget 'Menu'; sub Tk_cmd { \&Tk::_menu } Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure', 'index','insert','invoke','post','postcascade','type', 'unpost','yposition'); import Tk qw(Ev); sub CreateArgs { my ($package,$parent,$args) = @_; # Remove from hash %$args any configure-like # options which only apply at create time (e.g. -class for Frame) # return these as a list of -key => value pairs my @result = (); my $opt; foreach $opt (qw(-type -screen -visual -colormap)) { my $val = delete $args->{$opt}; push(@result, $opt => $val) if (defined $val); } return @result; } sub InitObject { my ($menu,$args) = @_; my $menuitems = delete $args->{-menuitems}; $menu->SUPER::InitObject($args); $menu->ConfigSpecs(-foreground => ['SELF']); if (defined $menuitems) { # If any other args do configure now if (%$args) { $menu->configure(%$args); %$args = (); } $menu->AddItems(@$menuitems) } } sub AddItems { my $menu = shift; ITEM: while (@_) { my $item = shift; if (!ref($item)) { $menu->separator; # A separator } else { my ($kind,$name,%minfo) = ( @$item ); my $invoke = delete $minfo{'-invoke'}; if (defined $name) { $minfo{-label} = $name unless defined($minfo{-label}); $menu->$kind(%minfo); } else { $menu->BackTrace("Don't recognize " . join(' ',@$item)); } } # A non-separator } } # #------------------------------------------------------------------------- # Elements of tkPriv that are used in this file: # # cursor - Saves the -cursor option for the posted menubutton. # focus - Saves the focus during a menu selection operation. # Focus gets restored here when the menu is unposted. # inMenubutton - The name of the menubutton widget containing # the mouse, or an empty string if the mouse is # not over any menubutton. # popup - If a menu has been popped up via tk_popup, this # gives the name of the menu. Otherwise this # value is empty. # postedMb - Name of the menubutton whose menu is currently # posted, or an empty string if nothing is posted # A grab is set on this widget. # relief - Used to save the original relief of the current # menubutton. # window - When the mouse is over a menu, this holds the # name of the menu; it's cleared when the mouse # leaves the menu. #------------------------------------------------------------------------- #------------------------------------------------------------------------- # Overall note: # This file is tricky because there are four different ways that menus # can be used: # # 1. As a pulldown from a menubutton. This is the most common usage. # In this style, the variable tkPriv(postedMb) identifies the posted # menubutton. # 2. As a torn-off menu copied from some other menu. In this style # tkPriv(postedMb) is empty, and the top-level menu is no # override-redirect. # 3. As an option menu, triggered from an option menubutton. In thi # style tkPriv(postedMb) identifies the posted menubutton. # 4. As a popup menu. In this style tkPriv(postedMb) is empty and # the top-level menu is override-redirect. # # The various binding procedures use the state described above to # distinguish the various cases and take different actions in each # case. #------------------------------------------------------------------------- # Bind -- # This procedure is invoked the first time the mouse enters a menubutton # widget or a menubutton widget receives the input focus. It creates # all of the class bindings for both menubuttons and menus. # # Arguments: # w - The widget that was just entered or just received # the input focus. # event - Indicates which event caused the procedure to be invoked # (Enter or FocusIn). It is used so that we can carry out # the functions of that event in addition to setting up # bindings. sub ClassInit { my ($class,$mw) = @_; # Must set focus when mouse enters a menu, in order to allow # mixed-mode processing using both the mouse and the keyboard. $mw->bind($class,'', 'NoOp'); $mw->bind($class,'', 'Enter'); $mw->bind($class,'', ['Leave',Ev('X'),Ev('Y'),Ev('s')]); $mw->bind($class,'', ['Motion',Ev('x'),Ev('y'),Ev('s')]); $mw->bind($class,'','ButtonDown'); $mw->bind($class,'',['Invoke',1]); $mw->bind($class,'',['Invoke',0]); $mw->bind($class,'',['Invoke',0]); $mw->bind($class,'','DoReturn'); $mw->bind($class,'','Escape'); $mw->bind($class,'','LeftArrow'); $mw->bind($class,'','RightArrow'); $mw->bind($class,'','UpArrow'); $mw->bind($class,'','DownArrow'); $mw->bind($class,'', ['TraverseWithinMenu',Ev('K')]); $mw->bind($class,'', ['TraverseWithinMenu',Ev('K')]); return $class; } sub DoReturn { my ($widget) = @_; $widget->eventGenerate(''); } sub UpArrow { my $menu = shift; if ($menu->cget('-type') eq 'menubar') { $menu->NextMenu('left'); } else { $menu->NextEntry(-1); } } sub DownArrow { my $menu = shift; if ($menu->cget('-type') eq 'menubar') { $menu->NextMenu('right'); } else { $menu->NextEntry(1); } } sub LeftArrow { my $menu = shift; if ($menu->cget('-type') eq 'menubar') { $menu->NextEntry(-1); } else { $menu->NextMenu('left'); } } sub RightArrow { my $menu = shift; if ($menu->cget('-type') eq 'menubar') { $menu->NextEntry(1); } else { $menu->NextMenu('right'); } } # Unpost -- # This procedure unposts a given menu, plus all of its ancestors up # to (and including) a menubutton, if any. It also restores various # values to what they were before the menu was posted, and releases # a grab if there's a menubutton involved. Special notes: # 1. It's important to unpost all menus before releasing the grab, so # that any Enter-Leave events (e.g. from menu back to main # application) have mode NotifyGrab. # 2. Be sure to enclose various groups of commands in "catch" so that # the procedure will complete even if the menubutton or the menu # or the grab window has been deleted. # # Arguments: # menu - Name of a menu to unpost. Ignored if there # is a posted menubutton. sub Unpost { my $menu = shift; my $mb = $Tk::postedMb; # Restore focus right away (otherwise X will take focus away when # the menu is unmapped and under some window managers (e.g. olvwm) # we'll lose the focus completely). eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus); undef $Tk::focus; # Unpost menu(s) and restore some stuff that's dependent on # what was posted. eval {local $SIG{__DIE__}; if (defined $mb) { $menu = $mb->cget('-menu'); $menu->unpost(); $Tk::postedMb = undef; $mb->configure('-cursor',$Tk::cursor); $mb->configure('-relief',$Tk::relief) } elsif (defined $Tk::popup) { $Tk::popup->unpost(); my $grab = $Tk::popup->grabCurrent; $grab->grabRelease if (defined $grab); undef $Tk::popup; } elsif (defined $menu && ref $menu && $menu->cget('-type') ne 'menubar' && $menu->cget('-type') ne 'tearoff' ) { # We're in a cascaded sub-menu from a torn-off menu or popup. # Unpost all the menus up to the toplevel one (but not # including the top-level torn-off one) and deactivate the # top-level torn off menu if there is one. while (1) { my $parent = $menu->parent; last if (!$parent->IsMenu || !$parent->ismapped); $parent->postcascade('none'); $parent->GenerateMenuSelect; $parent->activate('none'); my $type = $parent->cget('-type'); last if ($type eq 'menubar' || $type eq 'tearoff'); $menu = $parent } $menu->unpost() if ($menu->cget('-type') ne 'menubar'); } }; warn "$@" if ($@); if ($Tk::tearoff || $Tk::menubar) { # Release grab, if any. if (defined $menu && ref $menu) { my $grab = $menu->grabCurrent; $grab->grabRelease if (defined $grab); } RestoreOldGrab(); if ($Tk::menubar) { $Tk::menubar->configure(-cursor => $Tk::cursor); undef $Tk::menubar; } if ($Tk::platform ne 'unix') { undef $Tk::tearoff; } } } sub RestoreOldGrab { if (defined $Tk::oldGrab) { eval { local $SIG{__DIE__}; if ($Tk::grabStatus eq 'global') { $Tk::oldGrab->grabGlobal; } else { $Tk::oldGrab->grab; } }; undef $Tk::oldGrab; } } sub typeIS {my $w = shift; my $type = $w->type(shift); return defined $type && $type eq shift; } # Motion -- # This procedure is called to handle mouse motion events for menus. # It does two things. First, it resets the active element in the # menu, if the mouse is over the menu. Second, if a mouse button # is down, it posts and unposts cascade entries to match the mouse # position. # # Arguments: # menu - The menu window. # y - The y position of the mouse. # state - Modifier state (tells whether buttons are down). sub Motion { my $menu = shift; my $x = shift; my $y = shift; my $state = shift; my $t = $menu->cget('-type'); if ($menu->IS($Tk::window)) { if ($menu->cget('-type') eq 'menubar') { # if (defined($Tk::focus) && $Tk::focus != $menu) { $menu->activate("\@$x,$y"); $menu->GenerateMenuSelect; } } else { $menu->activate("\@$x,$y"); $menu->GenerateMenuSelect; } } if (($state & 0x1f00) != 0) { $menu->postcascade('active') } } # ButtonDown -- # Handles button presses in menus. There are a couple of tricky things # here: # 1. Change the posted cascade entry (if any) to match the mouse position. # 2. If there is a posted menubutton, must grab to the menubutton so # that it can track mouse motions over other menubuttons and change # the posted menu. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu # or one of its descendants) must grab to the top-level menu so that # we can track mouse motions across the entire menu hierarchy. # # Arguments: # menu - The menu window. sub ButtonDown { my $menu = shift; $menu->postcascade('active'); if (defined $Tk::postedMb) { $Tk::postedMb->grabGlobal } else { while ($menu->cget('-type') eq 'normal' && $menu->parent->IsMenu && $menu->parent->ismapped ) { $menu = $menu->parent; } if (!defined $Tk::menuBar) { $Tk::menuBar = $menu; $Tk::cursor = $menu->cget('-cursor'); $menu->configure(-cursor => 'arrow'); } # Don't update grab information if the grab window isn't changing. # Otherwise, we'll get an error when we unpost the menus and # restore the grab, since the old grab window will not be viewable # anymore. $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent)); # Must re-grab even if the grab window hasn't changed, in order # to release the implicit grab from the button press. $menu->grabGlobal if ($Tk::platform eq 'unix'); } } sub Enter { my $w = shift; my $ev = $w->XEvent; $Tk::window = $w; if ($w->cget('-type') eq 'tearoff') { if ($ev->m ne 'NotifyUngrab') { $w->SetFocus if ($Tk::platform eq 'unix'); } } $w->Motion($ev->x, $ev->y, $ev->s); } # Leave -- # This procedure is invoked to handle Leave events for a menu. It # deactivates everything unless the active element is a cascade element # and the mouse is now over the submenu. # # Arguments: # menu - The menu window. # rootx, rooty - Root coordinates of mouse. # state - Modifier state. sub Leave { my $menu = shift; my $rootx = shift; my $rooty = shift; my $state = shift; undef $Tk::window; return if ($menu->index('active') eq 'none'); if ($menu->typeIS('active','cascade')) { my $c = $menu->Containing($rootx,$rooty); return if (defined $c && $menu->entrycget('active','-menu')->IS($c)); } $menu->activate('none'); $menu->GenerateMenuSelect; } # Invoke -- # This procedure is invoked when button 1 is released over a menu. # It invokes the appropriate menu action and unposts the menu if # it came from a menubutton. # # Arguments: # w - Name of the menu widget. sub Invoke { my $w = shift; my $release = shift; if ($release && !defined($Tk::window)) { # Mouse was pressed over a menu without a menu button, then # dragged off the menu (possibly with a cascade posted) and # released. Unpost everything and quit. $w->postcascade('none'); $w->activate('none'); $w->eventGenerate('<>'); $w->Unpost; return; } my $type = $w->type('active'); if ($w->typeIS('active','cascade')) { $w->postcascade('active'); my $menu = $w->entrycget('active','-menu'); $menu->FirstEntry() if (defined $menu); } elsif ($w->typeIS('active','tearoff')) { $w->Unpost(); $w->tearOffMenu(); } elsif ($w->typeIS('active','menubar')) { $w->postcascade('none'); $w->activate('none'); $w->eventGenerate('<>'); $w->Unpost; } else { $w->Unpost(); $w->invoke('active') } } # Escape -- # This procedure is invoked for the Cancel (or Escape) key. It unposts # the given menu and, if it is the top-level menu for a menu button, # unposts the menu button as well. # # Arguments: # menu - Name of the menu window. sub Escape { my $menu = shift; my $parent = $menu->parent; if (!$parent->IsMenu) { $menu->Unpost() } elsif ($parent->cget('-type') eq 'menubar') { $menu->Unpost; RestoreOldGrab(); } else { $menu->NextMenu(-1) } } # LeftRight -- # This procedure is invoked to handle "left" and "right" traversal # motions in menus. It traverses to the next menu in a menu bar, # or into or out of a cascaded menu. # # Arguments: # menu - The menu that received the keyboard # event. # direction - Direction in which to move: "left" or "right" sub NextMenu { my $menu = shift; my $direction = shift; # First handle traversals into and out of cascaded menus. my $count; if ($direction eq 'right') { $count = 1; if ($menu->typeIS('active','cascade')) { $menu->postcascade('active'); my $m2 = $menu->entrycget('active','-menu'); $m2->FirstEntry if (defined $m2); return; } else { my $parent = $menu->parent; while ($parent->PathName ne '.') { if ($parent->IsMenu && $parent->cget('-type') eq 'menubar') { $parent->SetFocus; $parent->NextEntry(1); return; } $parent = $parent->parent; } } } else { $count = -1; my $m2 = $menu->parent; if ($m2->IsMenu) { if ($m2->cget('-type') ne 'menubar') { $menu->activate('none'); $menu->GenerateMenuSelect; $m2->SetFocus; # This code unposts any posted submenu in the parent. my $tmp = $m2->index('active'); $m2->activate('none'); $m2->activate($tmp); return; } } } # Can't traverse into or out of a cascaded menu. Go to the next # or previous menubutton, if that makes sense. my $m2 = $menu->parent; if ($m2->IsMenu) { if ($m2->cget('-type') eq 'menubar') { $m2->SetFocus; $m2->NextEntry(-1); return; } } my $w = $Tk::postedMb; return unless defined $w; my @buttons = $w->parent->children; my $length = @buttons; my $i = Tk::lsearch(\@buttons,$w)+$count; my $mb; while (1) { while ($i < 0) { $i += $length } while ($i >= $length) { $i += -$length } $mb = $buttons[$i]; last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled' && defined($mb->cget('-menu')) && $mb->cget('-menu')->index('last') ne 'none' ); return if ($mb == $w); $i += $count } $mb->PostFirst(); } # NextEntry -- # Activate the next higher or lower entry in the posted menu, # wrapping around at the ends. Disabled entries are skipped. # # Arguments: # menu - Menu window that received the keystroke. # count - 1 means go to the next lower entry, # -1 means go to the next higher entry. sub NextEntry { my $menu = shift; my $count = shift; if ($menu->index('last') eq 'none') { return; } my $length = $menu->index('last')+1; my $quitAfter = $length; my $active = $menu->index('active'); my $i = ($active eq 'none') ? 0 : $active+$count; while (1) { return if ($quitAfter <= 0); while ($i < 0) { $i += $length } while ($i >= $length) { $i += -$length } my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; last if (defined($state) && $state ne 'disabled'); return if ($i == $active); $i += $count; $quitAfter -= 1; } $menu->activate($i); $menu->GenerateMenuSelect; if ($menu->cget('-type') eq 'menubar' && $menu->type($i) eq 'cascade') { my $cascade = $menu->entrycget($i, '-menu'); $menu->postcascade($i); $cascade->FirstEntry if (defined $cascade); } } # tkTraverseWithinMenu # This procedure implements keyboard traversal within a menu. It # searches for an entry in the menu that has "char" underlined. If # such an entry is found, it is invoked and the menu is unposted. # # Arguments: # w - The name of the menu widget. # char - The character to look for; case is # ignored. If the string is empty then # nothing happens. sub TraverseWithinMenu { my $w = shift; my $char = shift; return unless (defined $char); $char = "\L$char"; my $last = $w->index('last'); return if ($last eq 'none'); for (my $i = 0;$i <= $last;$i += 1) { my $label = eval {local $SIG{__DIE__}; $w->entrycget($i,'-label') }; next unless defined($label); my $ul = $w->entrycget($i,'-underline'); if (defined $ul && $ul >= 0) { $label = substr("\L$label",$ul,1); if (defined($label) && $label eq $char) { if ($w->type($i) eq 'cascade') { $w->postcascade($i); $w->activate($i); my $m2 = $w->entrycget($i,'-menu'); $m2->FirstEntry if (defined $m2); } else { $w->Unpost(); $w->invoke($i); } return; } } } } sub FindMenu { my ($menu,$char) = @_; if ($menu->cget('-type') eq 'menubar') { if (!defined($char) || $char eq '') { $menu->FirstEntry; } else { $menu->TraverseWithinMenu($char); } return $menu; } return undef; } # FirstEntry -- # Given a menu, this procedure finds the first entry that isn't # disabled or a tear-off or separator, and activates that entry. # However, if there is already an active entry in the menu (e.g., # because of a previous call to tkPostOverPoint) then the active # entry isn't changed. This procedure also sets the input focus # to the menu. # # Arguments: # menu - Name of the menu window (possibly empty). sub FirstEntry { my $menu = shift; return if (!defined($menu) || $menu eq '' || !ref($menu)); $menu->SetFocus; return if ($menu->index('active') ne 'none'); my $last = $menu->index('last'); return if ($last eq 'none'); for (my $i = 0;$i <= $last;$i += 1) { my $state = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-state') }; if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff')) { $menu->activate($i); $menu->GenerateMenuSelect; if ($menu->type($i) eq 'cascade') { my $cascade = $menu->entrycget($i,'-menu'); if (defined $cascade) { $menu->postcascade($i); $cascade->FirstEntry; } } return; } } } # FindName -- # Given a menu and a text string, return the index of the menu entry # that displays the string as its label. If there is no such entry, # return an empty string. This procedure is tricky because some names # like "active" have a special meaning in menu commands, so we can't # always use the "index" widget command. # # Arguments: # menu - Name of the menu widget. # s - String to look for. sub FindName { my $menu = shift; my $s = shift; my $i = undef; if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/) { $i = eval {local $SIG{__DIE__}; $menu->index($s) }; return $i; } my $last = $menu->index('last'); return if ($last eq 'none'); for ($i = 0;$i <= $last;$i += 1) { my $label = eval {local $SIG{__DIE__}; $menu->entrycget($i,'-label') }; return $i if (defined $label && $label eq $s); } return undef; } # PostOverPoint -- # This procedure posts a given menu such that a given entry in the # menu is centered over a given point in the root window. It also # activates the given entry. # # Arguments: # menu - Menu to post. # x, y - Root coordinates of point. # entry - Index of entry within menu to center over (x,y). # If omitted or specified as {}, then the menu's # upper-left corner goes at (x,y). sub PostOverPoint { my $menu = shift; my $x = shift; my $y = shift; my $entry = shift; if (defined $entry) { if ($entry == $menu->index('last')) { $y -= ($menu->yposition($entry)+$menu->height)/2; } else { $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2; } $x -= $menu->reqwidth/2; } $menu->post($x,$y); if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled') { $menu->activate($entry); $menu->GenerateMenuSelect; } } # tk_popup -- # This procedure pops up a menu and sets things up for traversing # the menu and its submenus. # # Arguments: # menu - Name of the menu to be popped up. # x, y - Root coordinates at which to pop up the # menu. # entry - Index of a menu entry to center over (x,y). # If omitted or specified as {}, then menu's # upper-left corner goes at (x,y). sub Post { my $menu = shift; return unless (defined $menu); my $x = shift; my $y = shift; my $entry = shift; Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb)); $menu->PostOverPoint($x,$y,$entry); $menu->grabGlobal; $Tk::popup = $menu; $Tk::focus = $menu->focusCurrent; $menu->focus(); } sub SetFocus { my $menu = shift; $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus)); $menu->focus; } sub GenerateMenuSelect { my $menu = shift; $Tk::activeMenu = $menu; $Tk::activeItem = $menu->index('active'); $menu->eventGenerate('<>'); # FIXME } # Converted from tearoff.tcl -- # # This file contains procedures that implement tear-off menus. # # @(#) tearoff.tcl 1.3 94/12/17 16:05:25 # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # tkTearoffMenu -- # Given the name of a menu, this procedure creates a torn-off menu # that is identical to the given menu (including nested submenus). # The new torn-off menu exists as a toplevel window managed by the # window manager. The return value is the name of the new menu. # # Arguments: # w - The menu to be torn-off (duplicated). sub tearOffMenu { my $w = shift; my $x = (@_) ? shift : 0; my $y = (@_) ? shift : 0; $x = $w->rootx if $x == 0; $y = $w->rooty if $y == 0; # Find a unique name to use for the torn-off menu. Find the first # ancestor of w that is a toplevel but not a menu, and use this as # the parent of the new menu. This guarantees that the torn off # menu will be on the same screen as the original menu. By making # it a child of the ancestor, rather than a child of the menu, it # can continue to live even if the menu is deleted; it will go # away when the toplevel goes away. my $parent = $w->parent; while ($parent->toplevel != $parent || $parent->IsMenu) { $parent = $parent->parent; } my $menu = $w->clone($parent->PathName,'tearoff'); # Pick a title for the new menu by looking at the parent of the # original: if the parent is a menu, then use the text of the active # entry. If it's a menubutton then use its text. my $title = $w->cget('-title'); # print ref($w),' ',$w->PathName," $w\n"; unless (defined $title && length($title)) { $parent = $w->parent; if ($parent) { if ($parent->IsMenubutton) { $title = $parent->cget('-text'); } elsif ($parent->IsMenu) { $title = $parent->entrycget('active','-label'); } } } $menu->title($title) if (defined $title && length($title)); $menu->post($x,$y); # Set tkPriv(focus) on entry: otherwise the focus will get lost # after keyboard invocation of a sub-menu (it will stay on the # submenu). # This seems to conflict with class binding above # if this fires before the class binding the wrong thing # will get saved in $Tk::focus # $menu->bind('','EnterFocus'); $menu->Callback('-tearoffcommand'); return $menu; } # tkMenuDup -- # Given a menu (hierarchy), create a duplicate menu (hierarchy) # in a given window. # # Arguments: # src - Source window. Must be a menu. It and its # menu descendants will be duplicated at path. # path - Name to use for topmost menu in duplicate # hierarchy. sub tkMenuDup { my ($src,$path,$type) = @_; my ($pname,$name) = $path =~ /^(.*)\.([^\.]*)$/; ($name) = $src->PathName =~ /^.*\.([^\.]*)$/ unless $name; my $parent = ($pname) ? $src->Widget($pname) : $src->MainWindow; my %args = (Name => $name, -type => $type); foreach my $option ($src->configure()) { next if (@$option == 2); $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]}; } my $dst = ref($src)->new($parent,%args); # print "MenuDup $src $path $name $type ->",$dst->PathName,"\n"; $_[1] = $dst; if ($type eq 'tearoff') { $dst->transient($parent->toplevel); } my $last = $src->index('last'); if ($last ne 'none') { for (my $i = $src->cget('-tearoff'); $i <= $last; $i++) { my $type = $src->type($i); if (defined $type) { my @args = (); foreach my $option ($src->entryconfigure($i)) { next if (@$option == 2); push(@args,$$option[0],$$option[4]) if (defined $$option[4]); } $dst->add($type,@args); } } } # Duplicate the binding tags and bindings from the source menu. my @bindtags = $src->bindtags; $path = $src->PathName; foreach (@bindtags) { $_ = $dst if ($_ eq $path); } $dst->bindtags([@bindtags]); foreach my $event ($src->bind) { my $cb = $src->bind($event); # print "$event => $cb\n"; $dst->bind($event,$cb->Substitute($src,$dst)); } return $dst; } # Some convenience methods sub separator { require Tk::Menu::Item; shift->Separator(@_); } sub cascade { require Tk::Menu::Item; shift->Cascade(@_); } sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); } sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); } sub command { my ($menu,%args) = @_; require Tk::Menu::Item; if (exists $args{-button}) { # Backward compatible stuff from 'Menubar' my $button = delete $args{-button}; $button = ['Misc', -underline => 0 ] unless (defined $button); my @bargs = (); ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY'); $menu = $menu->Menubutton(-label => $button, @bargs); } $menu->Command(%args); } sub Menubutton { my ($menu,%args) = @_; my $name = delete($args{'-text'}) || $args{'-label'};; $args{'-label'} = $name if (defined $name); my $items = delete $args{'-menuitems'}; foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill)) { delete $args{$opt}; } if (defined($name) && !defined($args{-underline})) { my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef; if (defined($underline) && ($underline >= 0)) { $args{-underline} = $underline; $args{-label} = $name; } } my $hash = $menu->TkHash('MenuButtons'); my $mb = $hash->{$name}; if (defined $mb) { delete $args{'-tearoff'}; # too late! $mb->configure(%args) if %args; } else { $mb = $menu->cascade(%args); $hash->{$name} = $mb; } $mb->menu->AddItems(@$items) if defined($items) && @$items; return $mb; } sub BalloonInfo { my ($menu,$balloon,$X,$Y,@opt) = @_; my $i = $menu->index('active'); if ($i eq 'none') { my $y = $Y - $menu->rooty; $i = $menu->index("\@$y"); } foreach my $opt (@opt) { my $info = $balloon->GetOption($opt,$menu); if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY')) { $balloon->Subclient($i); return '' if $i eq 'none'; return ${$info}[$i] || ''; } return $info; } } 1; __END__