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