diff options
Diffstat (limited to 'Master/tlpkg/tlperl.old/lib/Tk/Menubutton.pm')
| -rw-r--r-- | Master/tlpkg/tlperl.old/lib/Tk/Menubutton.pm | 398 |
1 files changed, 398 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl.old/lib/Tk/Menubutton.pm b/Master/tlpkg/tlperl.old/lib/Tk/Menubutton.pm new file mode 100644 index 00000000000..59456b2dea2 --- /dev/null +++ b/Master/tlpkg/tlperl.old/lib/Tk/Menubutton.pm @@ -0,0 +1,398 @@ +# 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::Menubutton; +require Tk; + +use vars qw($VERSION); +$VERSION = '4.004'; # $Id: //depot/Tkutf8/Menubutton/Menubutton.pm#4 $ + +use base qw(Tk::Widget); + +Construct Tk::Widget 'Menubutton'; + +import Tk qw(&Ev $XS_VERSION); + +bootstrap Tk::Menubutton; + +sub Tk_cmd { \&Tk::menubutton } + +sub InitObject +{ + my ($mb,$args) = @_; + my $menuitems = delete $args->{-menuitems}; + my $tearoff = delete $args->{-tearoff}; + $mb->SUPER::InitObject($args); + if ((defined($menuitems) || defined($tearoff)) && %$args) + { + $mb->configure(%$args); + %$args = (); + } + $mb->menu(-tearoff => $tearoff) if (defined $tearoff); + $mb->AddItems(@$menuitems) if (defined $menuitems) +} + + +# +#------------------------------------------------------------------------- +# 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. +#------------------------------------------------------------------------- +# Menu::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) = @_; + $mw->bind($class,'<FocusIn>','NoOp'); + $mw->bind($class,'<Enter>','Enter'); + $mw->bind($class,'<Leave>','Leave'); + $mw->bind($class,'<1>','ButtonDown'); + $mw->bind($class,'<Motion>',['Motion','up',Ev('X'),Ev('Y')]); + $mw->bind($class,'<B1-Motion>',['Motion','down',Ev('X'),Ev('Y')]); + $mw->bind($class,'<ButtonRelease-1>','ButtonUp'); + $mw->bind($class,'<space>','PostFirst'); + $mw->bind($class,'<Return>','PostFirst'); + return $class; +} + +sub ButtonDown +{my $w = shift; + my $Ev = $w->XEvent; + $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton); +} + +sub PostFirst +{ + my $w = shift; + my $menu = $w->cget('-menu'); + $w->Post(); + $menu->FirstEntry() if (defined $menu); +} + + +# Enter -- +# This procedure is invoked when the mouse enters a menubutton +# widget. It activates the widget unless it is disabled. Note: +# this procedure is only invoked when mouse button 1 is *not* down. +# The procedure B1Enter is invoked if the button is down. +# +# Arguments: +# w - The name of the widget. +sub Enter +{ + my $w = shift; + $Tk::inMenubutton->Leave if (defined $Tk::inMenubutton); + $Tk::inMenubutton = $w; + if ($w->cget('-state') ne 'disabled') + { + $w->configure('-state','active') + } +} + +sub Leave +{ + my $w = shift; + $Tk::inMenubutton = undef; + return unless Tk::Exists($w); + if ($w->cget('-state') eq 'active') + { + $w->configure('-state','normal') + } +} +# Post -- +# Given a menubutton, this procedure does all the work of posting +# its associated menu and unposting any other menu that is currently +# posted. +# +# Arguments: +# w - The name of the menubutton widget whose menu +# is to be posted. +# x, y - Root coordinates of cursor, used for positioning +# option menus. If not specified, then the center +# of the menubutton is used for an option menu. +sub Post +{ + my $w = shift; + my $x = shift; + my $y = shift; + return if ($w->cget('-state') eq 'disabled'); + return if (defined $Tk::postedMb && $w == $Tk::postedMb); + my $menu = $w->cget('-menu'); + return unless (defined($menu) && $menu->index('last') ne 'none'); + + my $tearoff = $Tk::platform eq 'unix' || $menu->cget('-type') eq 'tearoff'; + + my $wpath = $w->PathName; + my $mpath = $menu->PathName; + unless (index($mpath,"$wpath.") == 0) + { + die "Cannot post $mpath : not a descendant of $wpath"; + } + + my $cur = $Tk::postedMb; + if (defined $cur) + { + Tk::Menu->Unpost(undef); # fixme + } + $Tk::cursor = $w->cget('-cursor'); + $Tk::relief = $w->cget('-relief'); + $w->configure('-cursor','arrow'); + $w->configure('-relief','raised'); + $Tk::postedMb = $w; + $Tk::focus = $w->focusCurrent; + $menu->activate('none'); + $menu->GenerateMenuSelect; + # If this looks like an option menubutton then post the menu so + # that the current entry is on top of the mouse. Otherwise post + # the menu just below the menubutton, as for a pull-down. + + eval + {local $SIG{'__DIE__'}; + my $dir = $w->cget('-direction'); + if ($dir eq 'above') + { + $menu->post($w->rootx, $w->rooty - $menu->ReqHeight); + } + elsif ($dir eq 'below') + { + $menu->post($w->rootx, $w->rooty + $w->Height); + } + elsif ($dir eq 'left') + { + my $x = $w->rootx - $menu->ReqWidth; + my $y = int((2*$w->rooty + $w->Height) / 2); + if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) + { + $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) + } + else + { + $menu->post($x,$y); + } + } + elsif ($dir eq 'right') + { + my $x = $w->rootx + $w->Width; + my $y = int((2*$w->rooty + $w->Height) / 2); + if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) + { + $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) + } + else + { + $menu->post($x,$y); + } + } + else + { + if ($w->cget('-indicatoron') == 1 && defined($w->cget('-textvariable'))) + { + if (!defined($y)) + { + $x = $w->rootx+$w->width/2; + $y = $w->rooty+$w->height/2 + } + $menu->PostOverPoint($x,$y,$menu->FindName($w->cget('-text'))) + } + else + { + $menu->post($w->rootx,$w->rooty+$w->height); + } + } + }; + if ($@) + { + Tk::Menu->Unpost; + die $@ + } + + $Tk::tearoff = $tearoff; + if ($tearoff) + { + $menu->focus; + $w->SaveGrabInfo; + $w->grabGlobal; + } +} +# Motion -- +# This procedure handles mouse motion events inside menubuttons, and +# also outside menubuttons when a menubutton has a grab (e.g. when a +# menu selection operation is in progress). +# +# Arguments: +# w - The name of the menubutton widget. +# upDown - "down" means button 1 is pressed, "up" means +# it isn't. +# rootx, rooty - Coordinates of mouse, in (virtual?) root window. +sub Motion +{ + my $w = shift; + my $upDown = shift; + my $rootx = shift; + my $rooty = shift; + return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w); + my $new = $w->Containing($rootx,$rooty); + if (defined($Tk::inMenubutton)) + { + if (!defined($new) || ($new != $Tk::inMenubutton && $w->toplevel != $new->toplevel)) + { + $Tk::inMenubutton->Leave(); + } + } + if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0 && + $w->cget('-indicatoron') == 0) + { + if ($upDown eq 'down') + { + $new->Post($rootx,$rooty); + } + else + { + $new->Enter(); + } + } +} +# ButtonUp -- +# This procedure is invoked to handle button 1 releases for menubuttons. +# If the release happens inside the menubutton then leave its menu +# posted with element 0 activated. Otherwise, unpost the menu. +# +# Arguments: +# w - The name of the menubutton widget. + +sub ButtonUp { + my $w = shift; + + my $tearoff = $Tk::platform eq 'unix' || (defined($w->cget('-menu')) && + $w->cget('-menu')->cget('-type') eq 'tearoff'); + if ($tearoff && (defined($Tk::postedMb) && $Tk::postedMb == $w) + && (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)) { + $Tk::postedMb->cget(-menu)->FirstEntry(); + } else { + Tk::Menu->Unpost(undef); + } +} # end ButtonUp + +# Some convenience methods + +sub menu +{ + my ($w,%args) = @_; + my $menu = $w->cget('-menu'); + if (!defined $menu) + { + require Tk::Menu; + $w->ColorOptions(\%args) if ($Tk::platform eq 'unix'); + $menu = $w->Menu(%args); + $w->configure('-menu'=>$menu); + } + else + { + $menu->configure(%args); + } + return $menu; +} + +sub separator { require Tk::Menu::Item; shift->menu->Separator(@_); } +sub command { require Tk::Menu::Item; shift->menu->Command(@_); } +sub cascade { require Tk::Menu::Item; shift->menu->Cascade(@_); } +sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); } +sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); } + +sub AddItems +{ + shift->menu->AddItems(@_); +} + +sub entryconfigure +{ + shift->menu->entryconfigure(@_); +} + +sub entrycget +{ + shift->menu->entrycget(@_); +} + +sub FindMenu +{ + my $child = shift; + my $char = shift; + my $ul = $child->cget('-underline'); + if (defined $ul && $ul >= 0 && $child->cget('-state') ne 'disabled') + { + my $char2 = $child->cget('-text'); + $char2 = substr("\L$char2",$ul,1) if (defined $char2); + if (!defined($char) || $char eq '' || (defined($char2) && "\l$char" eq $char2)) + { + $child->PostFirst; + return $child; + } + } + return undef; +} + +1; + +__END__ + + |