home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Menubutton.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  9.2 KB  |  341 lines
  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.  
  16. package Tk::Menubutton; 
  17. require Tk;
  18. use AutoLoader;
  19.  
  20. @ISA = qw(Tk::Widget);
  21.  
  22. Construct Tk::Widget 'Menubutton';
  23.  
  24. import Tk qw(&Ev);
  25.  
  26. bootstrap Tk::Menubutton $Tk::VERSION;
  27.  
  28. sub Tk_cmd { \&Tk::menubutton }
  29.  
  30. sub InitObject
  31. {
  32.  my ($mb,$args) = @_;
  33.  my $menuitems = delete $args->{-menuitems};
  34.  my $tearoff   = delete $args->{-tearoff};
  35.  $mb->SUPER::InitObject($args);
  36.  if ((defined($menuitems) || defined($tearoff)) && %$args)
  37.   {
  38.    $mb->configure(%$args);
  39.    %$args = ();
  40.   }
  41.  $mb->menu(-tearoff => $tearoff) if (defined $tearoff);
  42.  $mb->AddItems(@$menuitems) if (defined $menuitems)
  43. }
  44.  
  45. 1;
  46.  
  47. __END__
  48.  
  49.  
  50. #
  51. #-------------------------------------------------------------------------
  52. # Elements of tkPriv that are used in this file:
  53. #
  54. # cursor - Saves the -cursor option for the posted menubutton.
  55. # focus - Saves the focus during a menu selection operation.
  56. # Focus gets restored here when the menu is unposted.
  57. # inMenubutton - The name of the menubutton widget containing
  58. # the mouse, or an empty string if the mouse is
  59. # not over any menubutton.
  60. # popup - If a menu has been popped up via tk_popup, this
  61. # gives the name of the menu. Otherwise this
  62. # value is empty.
  63. # postedMb - Name of the menubutton whose menu is currently
  64. # posted, or an empty string if nothing is posted
  65. # A grab is set on this widget.
  66. # relief - Used to save the original relief of the current
  67. # menubutton.
  68. # window - When the mouse is over a menu, this holds the
  69. # name of the menu; it's cleared when the mouse
  70. # leaves the menu.
  71. #-------------------------------------------------------------------------
  72. #-------------------------------------------------------------------------
  73. # Overall note:
  74. # This file is tricky because there are four different ways that menus
  75. # can be used:
  76. #
  77. # 1. As a pulldown from a menubutton. This is the most common usage.
  78. # In this style, the variable tkPriv(postedMb) identifies the posted
  79. # menubutton.
  80. # 2. As a torn-off menu copied from some other menu. In this style
  81. # tkPriv(postedMb) is empty, and the top-level menu is no
  82. # override-redirect.
  83. # 3. As an option menu, triggered from an option menubutton. In thi
  84. # style tkPriv(postedMb) identifies the posted menubutton.
  85. # 4. As a popup menu. In this style tkPriv(postedMb) is empty and
  86. # the top-level menu is override-redirect.
  87. #
  88. # The various binding procedures use the state described above to
  89. # distinguish the various cases and take different actions in each
  90. # case.
  91. #-------------------------------------------------------------------------
  92. # Menu::Bind --
  93. # This procedure is invoked the first time the mouse enters a menubutton
  94. # widget or a menubutton widget receives the input focus. It creates
  95. # all of the class bindings for both menubuttons and menus.
  96. #
  97. # Arguments:
  98. # w - The widget that was just entered or just received
  99. # the input focus.
  100. # event - Indicates which event caused the procedure to be invoked
  101. # (Enter or FocusIn). It is used so that we can carry out
  102. # the functions of that event in addition to setting up
  103. # bindings.
  104. sub ClassInit
  105. {
  106.  my ($class,$mw) = @_;
  107.  $mw->bind($class,"<Enter>",'Enter');
  108.  $mw->bind($class,"<Leave>",'Leave');
  109.  $mw->bind($class,"<1>",'ButtonDown');
  110.  $mw->bind($class,"<Motion>",['Motion',"up",Ev(X),Ev(Y)]);
  111.  $mw->bind($class,"<B1-Motion>",['Motion',"down",Ev(X),Ev(Y)]);
  112.  $mw->bind($class,"<ButtonRelease-1>",'ButtonUp');
  113.  $mw->bind($class,"<space>",'PostFirst');
  114.  $mw->bind($class,"<Return>",'PostFirst');
  115.  return $class;
  116. }
  117.  
  118. sub ButtonDown
  119. {my $w = shift;
  120.  my $Ev = $w->XEvent;
  121.  $Tk::inMenubutton->Post($Ev->X,$Ev->Y) if (defined $Tk::inMenubutton);
  122. }
  123.  
  124. sub PostFirst
  125. {
  126.  my $w = shift;
  127.  my $menu = $w->cget("-menu");
  128.  $w->Post();
  129.  $menu->FirstEntry() if (defined $menu);
  130. }
  131.  
  132.  
  133. # Enter --
  134. # This procedure is invoked when the mouse enters a menubutton
  135. # widget. It activates the widget unless it is disabled. Note:
  136. # this procedure is only invoked when mouse button 1 is *not* down.
  137. # The procedure B1Enter is invoked if the button is down.
  138. #
  139. # Arguments:
  140. # w - The name of the widget.
  141. sub Enter
  142. {
  143.  my $w = shift;
  144.  $Tk::inMenubutton->Leave if (defined $Tk::inMenubutton);
  145.  $Tk::inMenubutton = $w;
  146.  if ($w->cget("-state") ne "disabled")
  147.   {
  148.    $w->configure("-state","active")
  149.   }
  150. }
  151. # Leave --
  152. # This procedure is invoked when the mouse leaves a menubutton widget.
  153. # It de-activates the widget.
  154. #
  155. # Arguments:
  156. # w - The name of the widget.
  157. sub Leave
  158. {
  159.  my $w = shift;
  160.  $Tk::inMenubutton = undef;
  161.  if ($w->cget("-state") eq "active")
  162.   {
  163.    $w->configure("-state","normal")
  164.   }
  165. }
  166. # Post --
  167. # Given a menubutton, this procedure does all the work of posting
  168. # its associated menu and unposting any other menu that is currently
  169. # posted.
  170. #
  171. # Arguments:
  172. # w - The name of the menubutton widget whose menu
  173. # is to be posted.
  174. # x, y - Root coordinates of cursor, used for positioning
  175. # option menus. If not specified, then the center
  176. # of the menubutton is used for an option menu.
  177. sub Post
  178. {
  179.  my $w = shift;
  180.  my $x = shift;
  181.  my $y = shift;
  182.  return if ($w->cget("-state") eq "disabled");
  183.  return if (defined $Tk::postedMb && $w == $Tk::postedMb);
  184.  my $menu = $w->cget("-menu");
  185.  return unless (defined($menu) && $menu->index('last') ne 'none');
  186.  
  187.  my $wpath = $w->PathName;
  188.  my $mpath = $menu->PathName;
  189.  unless (index($mpath,"$wpath.") == 0)
  190.   {
  191.    die "Cannot post $mpath : not a descendant of $wpath";
  192.   }
  193.  
  194.  my $cur = $Tk::postedMb;
  195.  if (defined $cur)
  196.   {
  197.    Tk::Menu->Unpost(undef); # fixme
  198.   }
  199.  $Tk::cursor = $w->cget("-cursor");
  200.  $Tk::relief = $w->cget("-relief");
  201.  $w->configure("-cursor","arrow");
  202.  $w->configure("-relief","raised");
  203.  $Tk::postedMb = $w;
  204.  $Tk::focus = $w->focusCurrent;
  205.  $menu->activate("none");
  206.  # If this looks like an option menubutton then post the menu so
  207.  # that the current entry is on top of the mouse. Otherwise post
  208.  # the menu just below the menubutton, as for a pull-down.
  209.  if ($w->cget("-indicatoron") == 1 && defined($w->cget("-textvariable")))
  210.   {
  211.    if (!defined($y))
  212.     {
  213.      $x = $w->rootx+$w->width/2;
  214.      $y = $w->rooty+$w->height/2
  215.     }
  216.    $menu->PostOverPoint($x,$y,$menu->FindName($w->cget("-text")))
  217.   }
  218.  else
  219.   {
  220.    $menu->post($w->rootx,$w->rooty+$w->height);
  221.   }
  222.  $menu->Enter();
  223.  $w->grab("-global")
  224. }
  225. # Motion --
  226. # This procedure handles mouse motion events inside menubuttons, and
  227. # also outside menubuttons when a menubutton has a grab (e.g. when a
  228. # menu selection operation is in progress).
  229. #
  230. # Arguments:
  231. # w - The name of the menubutton widget.
  232. # upDown - "down" means button 1 is pressed, "up" means
  233. # it isn't.
  234. # rootx, rooty - Coordinates of mouse, in (virtual?) root window.
  235. sub Motion
  236. {
  237.  my $w = shift;
  238.  my $upDown = shift;
  239.  my $rootx = shift;
  240.  my $rooty = shift;
  241.  return if (defined($Tk::inMenubutton) && $Tk::inMenubutton == $w);
  242.  my $new = $w->Containing($rootx,$rooty) if defined $w->Containing($rootx,$rooty);
  243.  return if ! defined $new;
  244.  if (defined($Tk::inMenubutton) && $new != $Tk::inMenubutton)
  245.   {
  246.    $Tk::inMenubutton->Leave();
  247.   }
  248.  if (defined($new) && $new->IsMenubutton && $new->cget('-indicatoron') == 0)
  249.   {
  250.    if ($upDown eq "down")
  251.     {
  252.      $new->Post($rootx,$rooty);
  253.     }
  254.    else
  255.     {
  256.      $new->Enter();
  257.     }
  258.   }
  259. }
  260. # ButtonUp --
  261. # This procedure is invoked to handle button 1 releases for menubuttons.
  262. # If the release happens inside the menubutton then leave its menu
  263. # posted with element 0 activated. Otherwise, unpost the menu.
  264. #
  265. # Arguments:
  266. # w - The name of the menubutton widget.
  267. sub ButtonUp
  268. {
  269.  my $w = shift;
  270.  if (defined($Tk::postedMb) && $Tk::postedMb == $w && 
  271.      defined($Tk::inMenubutton) && $Tk::inMenubutton == $w)
  272.   {
  273.    my $menu = $Tk::postedMb->cget("-menu");
  274.    $menu->FirstEntry() if (defined $menu);
  275.   }
  276.  else
  277.   {
  278.    Tk::Menu->Unpost(undef); # fixme
  279.   }
  280. }
  281.  
  282. # Some convenience methods 
  283.  
  284. sub menu
  285. {
  286.  my ($w,%args) = @_;
  287.  my $menu = $w->cget('-menu');
  288.  if (!defined $menu)
  289.   {
  290.    require Tk::Menu;
  291.    $w->ColorOptions(\%args); 
  292.    $menu = $w->Menu(%args);
  293.    $w->configure('-menu'=>$menu);
  294.   }
  295.  else
  296.   {
  297.    $menu->configure(%args);
  298.   }
  299.  return $menu;
  300. }
  301.  
  302. sub separator   { require Tk::Menu::Item; shift->menu->Separator(@_);   }
  303. sub command     { require Tk::Menu::Item; shift->menu->Command(@_);     }
  304. sub cascade     { require Tk::Menu::Item; shift->menu->Cascade(@_);     }
  305. sub checkbutton { require Tk::Menu::Item; shift->menu->Checkbutton(@_); }
  306. sub radiobutton { require Tk::Menu::Item; shift->menu->Radiobutton(@_); }
  307.  
  308. sub AddItems
  309. {
  310.  shift->menu->AddItems(@_);
  311. }
  312.  
  313. sub entryconfigure
  314. {
  315.  shift->menu->entryconfigure(@_);
  316. }
  317.  
  318. sub entrycget
  319. {
  320.  shift->menu->entrycget(@_);
  321. }
  322.  
  323. sub FindMenu
  324. {
  325.  my $child = shift;
  326.  my $char = shift;
  327.  my $ul = $child->cget("-underline");
  328.  if (defined $ul && $ul >= 0 && $child->cget("-state") ne "disabled")
  329.   {
  330.    my $char2 = $child->cget("-text");
  331.    $char2 = substr("\L$char2",$ul,1) if (defined $char2);
  332.    if (!defined($char) || $char eq "" || (defined($char2) && "\l$char" eq $char2))
  333.     {
  334.      return $child;
  335.     }
  336.   }
  337.  return undef;
  338. }
  339.  
  340. 1;
  341.