diff options
Diffstat (limited to 'Master/tlpkg/tlperl.old/lib/Tk/Menu.pm')
-rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/Menu.pm | 1145 |
1 files changed, 0 insertions, 1145 deletions
diff --git a/Master/tlpkg/tlperl.old/lib/Tk/Menu.pm b/Master/tlpkg/tlperl.old/lib/Tk/Menu.pm deleted file mode 100644 index 91e9aceed61..00000000000 --- a/Master/tlpkg/tlperl.old/lib/Tk/Menu.pm +++ /dev/null @@ -1,1145 +0,0 @@ -# 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,'<FocusIn>', 'NoOp'); - $mw->bind($class,'<Enter>', 'Enter'); - $mw->bind($class,'<Leave>', ['Leave',Ev('X'),Ev('Y'),Ev('s')]); - $mw->bind($class,'<Motion>', ['Motion',Ev('x'),Ev('y'),Ev('s')]); - $mw->bind($class,'<ButtonPress>','ButtonDown'); - $mw->bind($class,'<ButtonRelease>',['Invoke',1]); - $mw->bind($class,'<space>',['Invoke',0]); - $mw->bind($class,'<Return>',['Invoke',0]); - $mw->bind($class,'<Escape>','Escape'); - $mw->bind($class,'<Left>','LeftArrow'); - $mw->bind($class,'<Right>','RightArrow'); - $mw->bind($class,'<Up>','UpArrow'); - $mw->bind($class,'<Down>','DownArrow'); - $mw->bind($class,'<KeyPress>', ['TraverseWithinMenu',Ev('K')]); - $mw->bind($class,'<Alt-KeyPress>', ['TraverseWithinMenu',Ev('K')]); - return $class; -} - -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('<<MenuSelect>>'); - $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('<<MenuSelect>>'); - $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('<<MenuSelect>>'); # 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 <Enter> class binding above - # if this fires before the class binding the wrong thing - # will get saved in $Tk::focus - # $menu->bind('<Enter>','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__ - - |