home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2004 July / APC0407D2.iso / workshop / apache / files / ActivePerl-5.8.3.809-MSWin32-x86.msi / _e2c080c7cf92f81e8668b4e426c7b1fe < prev    next >
Encoding:
Text File  |  2004-02-02  |  29.1 KB  |  1,131 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. package Tk::Menu;
  16. require Tk;
  17. require Tk::Widget;
  18. require Tk::Wm;
  19. require Tk::Derived;
  20. require Tk::Menu::Item;
  21.  
  22.  
  23. use vars qw($VERSION);
  24. $VERSION = '3.045'; # $Id: //depot/Tk8/Tk/Menu.pm#45 $
  25.  
  26. use strict;
  27.  
  28. use base  qw(Tk::Wm Tk::Derived Tk::Widget);
  29.  
  30. Construct Tk::Widget 'Menu';
  31.  
  32. sub Tk_cmd { \&Tk::_menu }
  33.  
  34. Tk::Methods('activate','add','clone','delete','entrycget','entryconfigure',
  35.             'index','insert','invoke','post','postcascade','type',
  36.             'unpost','yposition');
  37.  
  38. import Tk qw(Ev);
  39.  
  40. sub CreateArgs
  41. {
  42.  my ($package,$parent,$args) = @_;
  43.  # Remove from hash %$args any configure-like
  44.  # options which only apply at create time (e.g. -class for Frame)
  45.  # return these as a list of -key => value pairs
  46.  my @result = ();
  47.  my $opt;
  48.  foreach $opt (qw(-type -screen -visual -colormap))
  49.   {
  50.    my $val = delete $args->{$opt};
  51.    push(@result, $opt => $val) if (defined $val);
  52.   }
  53.  return @result;
  54. }
  55.  
  56. sub InitObject
  57. {
  58.  my ($menu,$args) = @_;
  59.  my $menuitems = delete $args->{-menuitems};
  60.  $menu->SUPER::InitObject($args);
  61.  if (defined $menuitems)
  62.   {
  63.    # If any other args do configure now
  64.    if (%$args)
  65.     {
  66.      $menu->configure(%$args);
  67.      %$args = ();
  68.     }
  69.    $menu->AddItems(@$menuitems)
  70.   }
  71. }
  72.  
  73. sub AddItems
  74. {
  75.  my $menu = shift;
  76.  ITEM:
  77.  while (@_)
  78.   {
  79.    my $item = shift;
  80.    if (!ref($item))
  81.     {
  82.      $menu->separator;  # A separator
  83.     }
  84.    else
  85.     {
  86.      my ($kind,$name,%minfo) = ( @$item );
  87.      my $invoke = delete $minfo{'-invoke'};
  88.      if (defined $name)
  89.       {
  90.        $minfo{-label} = $name unless defined($minfo{-label});
  91.        $menu->$kind(%minfo);
  92.       }
  93.      else
  94.       {
  95.        $menu->BackTrace("Don't recognize " . join(' ',@$item));
  96.       }
  97.     }  # A non-separator
  98.   }
  99. }
  100.  
  101. #
  102. #-------------------------------------------------------------------------
  103. # Elements of tkPriv that are used in this file:
  104. #
  105. # cursor - Saves the -cursor option for the posted menubutton.
  106. # focus - Saves the focus during a menu selection operation.
  107. # Focus gets restored here when the menu is unposted.
  108. # inMenubutton - The name of the menubutton widget containing
  109. # the mouse, or an empty string if the mouse is
  110. # not over any menubutton.
  111. # popup - If a menu has been popped up via tk_popup, this
  112. # gives the name of the menu. Otherwise this
  113. # value is empty.
  114. # postedMb - Name of the menubutton whose menu is currently
  115. # posted, or an empty string if nothing is posted
  116. # A grab is set on this widget.
  117. # relief - Used to save the original relief of the current
  118. # menubutton.
  119. # window - When the mouse is over a menu, this holds the
  120. # name of the menu; it's cleared when the mouse
  121. # leaves the menu.
  122. #-------------------------------------------------------------------------
  123. #-------------------------------------------------------------------------
  124. # Overall note:
  125. # This file is tricky because there are four different ways that menus
  126. # can be used:
  127. #
  128. # 1. As a pulldown from a menubutton. This is the most common usage.
  129. # In this style, the variable tkPriv(postedMb) identifies the posted
  130. # menubutton.
  131. # 2. As a torn-off menu copied from some other menu. In this style
  132. # tkPriv(postedMb) is empty, and the top-level menu is no
  133. # override-redirect.
  134. # 3. As an option menu, triggered from an option menubutton. In thi
  135. # style tkPriv(postedMb) identifies the posted menubutton.
  136. # 4. As a popup menu. In this style tkPriv(postedMb) is empty and
  137. # the top-level menu is override-redirect.
  138. #
  139. # The various binding procedures use the state described above to
  140. # distinguish the various cases and take different actions in each
  141. # case.
  142. #-------------------------------------------------------------------------
  143. # Bind --
  144. # This procedure is invoked the first time the mouse enters a menubutton
  145. # widget or a menubutton widget receives the input focus. It creates
  146. # all of the class bindings for both menubuttons and menus.
  147. #
  148. # Arguments:
  149. # w - The widget that was just entered or just received
  150. # the input focus.
  151. # event - Indicates which event caused the procedure to be invoked
  152. # (Enter or FocusIn). It is used so that we can carry out
  153. # the functions of that event in addition to setting up
  154. # bindings.
  155. sub ClassInit
  156. {
  157.  my ($class,$mw) = @_;
  158.  # Must set focus when mouse enters a menu, in order to allow
  159.  # mixed-mode processing using both the mouse and the keyboard.
  160.  $mw->bind($class,'<FocusIn>', 'NoOp');
  161.  $mw->bind($class,'<Enter>', 'Enter');
  162.  $mw->bind($class,'<Leave>', ['Leave',Ev('X'),Ev('Y'),Ev('s')]);
  163.  $mw->bind($class,'<Motion>', ['Motion',Ev('x'),Ev('y'),Ev('s')]);
  164.  $mw->bind($class,'<ButtonPress>','ButtonDown');
  165.  $mw->bind($class,'<ButtonRelease>',['Invoke',1]);
  166.  $mw->bind($class,'<space>',['Invoke',0]);
  167.  $mw->bind($class,'<Return>',['Invoke',0]);
  168.  $mw->bind($class,'<Escape>','Escape');
  169.  $mw->bind($class,'<Left>','LeftArrow');
  170.  $mw->bind($class,'<Right>','RightArrow');
  171.  $mw->bind($class,'<Up>','UpArrow');
  172.  $mw->bind($class,'<Down>','DownArrow');
  173.  $mw->bind($class,'<KeyPress>', ['TraverseWithinMenu',Ev('K')]);
  174.  $mw->bind($class,'<Alt-KeyPress>', ['TraverseWithinMenu',Ev('K')]);
  175.  return $class;
  176. }
  177.  
  178. sub UpArrow
  179. {
  180.  my $menu = shift;
  181.  if ($menu->cget('-type') eq 'menubar')
  182.   {
  183.    $menu->NextMenu('left');
  184.   }
  185.  else
  186.   {
  187.    $menu->NextEntry(-1);
  188.   }
  189. }
  190.  
  191. sub DownArrow
  192. {
  193.  my $menu = shift;
  194.  if ($menu->cget('-type') eq 'menubar')
  195.   {
  196.    $menu->NextMenu('right');
  197.   }
  198.  else
  199.   {
  200.    $menu->NextEntry(1);
  201.   }
  202. }
  203.  
  204. sub LeftArrow
  205. {
  206.  my $menu = shift;
  207.  if ($menu->cget('-type') eq 'menubar')
  208.   {
  209.    $menu->NextEntry(-1);
  210.   }
  211.  else
  212.   {
  213.    $menu->NextMenu('left');
  214.   }
  215. }
  216.  
  217. sub RightArrow
  218. {
  219.  my $menu = shift;
  220.  if ($menu->cget('-type') eq 'menubar')
  221.   {
  222.    $menu->NextEntry(1);
  223.   }
  224.  else
  225.   {
  226.    $menu->NextMenu('right');
  227.   }
  228. }
  229.  
  230.  
  231.  
  232. # Unpost --
  233. # This procedure unposts a given menu, plus all of its ancestors up
  234. # to (and including) a menubutton, if any. It also restores various
  235. # values to what they were before the menu was posted, and releases
  236. # a grab if there's a menubutton involved. Special notes:
  237. # 1. It's important to unpost all menus before releasing the grab, so
  238. # that any Enter-Leave events (e.g. from menu back to main
  239. # application) have mode NotifyGrab.
  240. # 2. Be sure to enclose various groups of commands in "catch" so that
  241. # the procedure will complete even if the menubutton or the menu
  242. # or the grab window has been deleted.
  243. #
  244. # Arguments:
  245. # menu - Name of a menu to unpost. Ignored if there
  246. # is a posted menubutton.
  247. sub Unpost
  248. {
  249.  my $menu = shift;
  250.  my $mb = $Tk::postedMb;
  251.  
  252.  # Restore focus right away (otherwise X will take focus away when
  253.  # the menu is unmapped and under some window managers (e.g. olvwm)
  254.  # we'll lose the focus completely).
  255.  
  256.  eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus);
  257.  undef $Tk::focus;
  258.  
  259.  # Unpost menu(s) and restore some stuff that's dependent on
  260.  # what was posted.
  261.  eval {local $SIG{__DIE__};
  262.    if (defined $mb)
  263.      {
  264.       $menu = $mb->cget('-menu');
  265.       $menu->unpost();
  266.       $Tk::postedMb = undef;
  267.       $mb->configure('-cursor',$Tk::cursor);
  268.       $mb->configure('-relief',$Tk::relief)
  269.      }
  270.     elsif (defined $Tk::popup)
  271.      {
  272.       $Tk::popup->unpost();
  273.       my $grab = $Tk::popup->grabCurrent;
  274.       $grab->grabRelease if (defined $grab);
  275.  
  276.       undef $Tk::popup;
  277.      }
  278.     elsif (defined $menu && ref $menu &&
  279.            $menu->cget('-type') ne 'menubar' &&
  280.            $menu->cget('-type') ne 'tearoff'
  281.           )
  282.      {
  283.       # We're in a cascaded sub-menu from a torn-off menu or popup.
  284.       # Unpost all the menus up to the toplevel one (but not
  285.       # including the top-level torn-off one) and deactivate the
  286.       # top-level torn off menu if there is one.
  287.       while (1)
  288.        {
  289.         my $parent = $menu->parent;
  290.         last if (!$parent->IsMenu || !$parent->ismapped);
  291.         $parent->postcascade('none');
  292.         $parent->GenerateMenuSelect;
  293.         $parent->activate('none');
  294.         my $type = $parent->cget('-type');
  295.         last if ($type eq 'menubar' || $type eq 'tearoff');
  296.         $menu = $parent
  297.        }
  298.       $menu->unpost() if ($menu->cget('-type') ne 'menubar');
  299.      }
  300.   };
  301.  warn "$@" if ($@);
  302.  if ($Tk::tearoff || $Tk::menubar)
  303.   {
  304.    # Release grab, if any.
  305.    if (defined $menu && ref $menu)
  306.     {
  307.      my $grab = $menu->grabCurrent;
  308.      $grab->grabRelease if (defined $grab);
  309.     }
  310.    RestoreOldGrab();
  311.    if ($Tk::menubar)
  312.     {
  313.      $Tk::menubar->configure(-cursor => $Tk::cursor);
  314.      undef $Tk::menubar;
  315.     }
  316.    if ($Tk::platform ne 'unix')
  317.     {
  318.      undef $Tk::tearoff;
  319.     }
  320.   }
  321. }
  322.  
  323. sub RestoreOldGrab
  324. {
  325.  if (defined $Tk::oldGrab)
  326.   {
  327.    eval
  328.     {
  329.      local $SIG{__DIE__};
  330.      if ($Tk::grabStatus eq 'global')
  331.       {
  332.        $Tk::oldGrab->grabGlobal;
  333.       }
  334.      else
  335.       {
  336.        $Tk::oldGrab->grab;
  337.       }
  338.     };
  339.    undef $Tk::oldGrab;
  340.   }
  341. }
  342.  
  343. sub typeIS
  344. {my $w = shift;
  345.  my $type = $w->type(shift);
  346.  return defined $type && $type eq shift;
  347. }
  348.  
  349. # Motion --
  350. # This procedure is called to handle mouse motion events for menus.
  351. # It does two things. First, it resets the active element in the
  352. # menu, if the mouse is over the menu.  Second, if a mouse button
  353. # is down, it posts and unposts cascade entries to match the mouse
  354. # position.
  355. #
  356. # Arguments:
  357. # menu - The menu window.
  358. # y - The y position of the mouse.
  359. # state - Modifier state (tells whether buttons are down).
  360. sub Motion
  361. {
  362.  my $menu = shift;
  363.  my $x = shift;
  364.  my $y = shift;
  365.  my $state = shift;
  366.  my $t     = $menu->cget('-type');
  367.  
  368.  if ($menu->IS($Tk::window))
  369.   {
  370.    if ($menu->cget('-type') eq 'menubar')
  371.     {
  372. #    if (defined($Tk::focus) && $Tk::focus != $menu)
  373.       {
  374.        $menu->activate("\@$x,$y");
  375.        $menu->GenerateMenuSelect;
  376.       }
  377.     }
  378.    else
  379.     {
  380.      $menu->activate("\@$x,$y");
  381.      $menu->GenerateMenuSelect;
  382.     }
  383.   }
  384.  if (($state & 0x1f00) != 0)
  385.   {
  386.    $menu->postcascade('active')
  387.   }
  388. }
  389. # ButtonDown --
  390. # Handles button presses in menus. There are a couple of tricky things
  391. # here:
  392. # 1. Change the posted cascade entry (if any) to match the mouse position.
  393. # 2. If there is a posted menubutton, must grab to the menubutton so
  394. #    that it can track mouse motions over other menubuttons and change
  395. #    the posted menu.
  396. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  397. #    or one of its descendants) must grab to the top-level menu so that
  398. #    we can track mouse motions across the entire menu hierarchy.
  399.  
  400. #
  401. # Arguments:
  402. # menu - The menu window.
  403. sub ButtonDown
  404. {
  405.  my $menu = shift;
  406.  $menu->postcascade('active');
  407.  if (defined $Tk::postedMb)
  408.   {
  409.    $Tk::postedMb->grabGlobal
  410.   }
  411.  else
  412.   {
  413.    while ($menu->cget('-type') eq 'normal'
  414.           && $menu->parent->IsMenu
  415.           && $menu->parent->ismapped
  416.          )
  417.     {
  418.      $menu = $menu->parent;
  419.     }
  420.  
  421.    if (!defined $Tk::menuBar)
  422.     {
  423.      $Tk::menuBar = $menu;
  424.      $Tk::cursor = $menu->cget('-cursor');
  425.      $menu->configure(-cursor => 'arrow');
  426.     }
  427.  
  428.    # Don't update grab information if the grab window isn't changing.
  429.    # Otherwise, we'll get an error when we unpost the menus and
  430.    # restore the grab, since the old grab window will not be viewable
  431.    # anymore.
  432.  
  433.    $menu->SaveGrabInfo unless ($menu->IS($menu->grabCurrent));
  434.  
  435.    # Must re-grab even if the grab window hasn't changed, in order
  436.    # to release the implicit grab from the button press.
  437.  
  438.    $menu->grabGlobal if ($Tk::platform eq 'unix');
  439.   }
  440. }
  441.  
  442. sub Enter
  443. {
  444.  my $w = shift;
  445.  my $ev = $w->XEvent;
  446.  $Tk::window = $w;
  447.  if ($w->cget('-type') eq 'tearoff')
  448.   {
  449.    if ($ev->m ne 'NotifyUngrab')
  450.     {
  451.      $w->SetFocus if ($Tk::platform eq 'unix');
  452.     }
  453.   }
  454.  $w->Motion($ev->x, $ev->y, $ev->s);
  455. }
  456.  
  457. # Leave --
  458. # This procedure is invoked to handle Leave events for a menu. It
  459. # deactivates everything unless the active element is a cascade element
  460. # and the mouse is now over the submenu.
  461. #
  462. # Arguments:
  463. # menu - The menu window.
  464. # rootx, rooty - Root coordinates of mouse.
  465. # state - Modifier state.
  466. sub Leave
  467. {
  468.  my $menu = shift;
  469.  my $rootx = shift;
  470.  my $rooty = shift;
  471.  my $state = shift;
  472.  undef $Tk::window;
  473.  return if ($menu->index('active') eq 'none');
  474.  if ($menu->typeIS('active','cascade'))
  475.   {
  476.    my $c = $menu->Containing($rootx,$rooty);
  477.    return if (defined $c && $menu->entrycget('active','-menu')->IS($c));
  478.   }
  479.  $menu->activate('none');
  480.  $menu->GenerateMenuSelect;
  481. }
  482.  
  483. # Invoke --
  484. # This procedure is invoked when button 1 is released over a menu.
  485. # It invokes the appropriate menu action and unposts the menu if
  486. # it came from a menubutton.
  487. #
  488. # Arguments:
  489. # w - Name of the menu widget.
  490. sub Invoke
  491. {
  492.  my $w = shift;
  493.  my $release = shift;
  494.  
  495.  if ($release && !defined($Tk::window))
  496.   {
  497.    # Mouse was pressed over a menu without a menu button, then
  498.    # dragged off the menu (possibly with a cascade posted) and
  499.    # released.  Unpost everything and quit.
  500.  
  501.    $w->postcascade('none');
  502.    $w->activate('none');
  503.    $w->eventGenerate('<<MenuSelect>>');
  504.    $w->Unpost;
  505.    return;
  506.   }
  507.  
  508.  my $type = $w->type('active');
  509.  if ($w->typeIS('active','cascade'))
  510.   {
  511.    $w->postcascade('active');
  512.    my $menu = $w->entrycget('active','-menu');
  513.    $menu->FirstEntry() if (defined $menu);
  514.   }
  515.  elsif ($w->typeIS('active','tearoff'))
  516.   {
  517.    $w->Unpost();
  518.    $w->tearOffMenu();
  519.   }
  520.  elsif ($w->typeIS('active','menubar'))
  521.   {
  522.    $w->postcascade('none');
  523.    $w->activate('none');
  524.    $w->eventGenerate('<<MenuSelect>>');
  525.    $w->Unpost;
  526.   }
  527.  else
  528.   {
  529.    $w->Unpost();
  530.    $w->invoke('active')
  531.   }
  532. }
  533. # Escape --
  534. # This procedure is invoked for the Cancel (or Escape) key. It unposts
  535. # the given menu and, if it is the top-level menu for a menu button,
  536. # unposts the menu button as well.
  537. #
  538. # Arguments:
  539. # menu - Name of the menu window.
  540. sub Escape
  541. {
  542.  my $menu = shift;
  543.  my $parent = $menu->parent;
  544.  if (!$parent->IsMenu)
  545.   {
  546.    $menu->Unpost()
  547.   }
  548.  elsif ($parent->cget('-type') eq 'menubar')
  549.   {
  550.    $menu->Unpost;
  551.    RestoreOldGrab();
  552.   }
  553.  else
  554.   {
  555.    $menu->NextMenu(-1)
  556.   }
  557. }
  558. # LeftRight --
  559. # This procedure is invoked to handle "left" and "right" traversal
  560. # motions in menus. It traverses to the next menu in a menu bar,
  561. # or into or out of a cascaded menu.
  562. #
  563. # Arguments:
  564. # menu - The menu that received the keyboard
  565. # event.
  566. # direction - Direction in which to move: "left" or "right"
  567. sub NextMenu
  568. {
  569.  my $menu = shift;
  570.  my $direction = shift;
  571.  # First handle traversals into and out of cascaded menus.
  572.  my $count;
  573.  if ($direction eq 'right')
  574.   {
  575.    $count = 1;
  576.    if ($menu->typeIS('active','cascade'))
  577.     {
  578.      $menu->postcascade('active');
  579.      my $m2 = $menu->entrycget('active','-menu');
  580.      $m2->FirstEntry if (defined $m2);
  581.      return;
  582.     }
  583.    else
  584.     {
  585.      my $parent = $menu->parent;
  586.      while ($parent->PathName ne '.')
  587.       {
  588.        if ($parent->IsMenu && $parent->cget('-type') eq 'menubar')
  589.         {
  590.          $parent->SetFocus;
  591.          $parent->NextEntry(1);
  592.          return;
  593.         }
  594.        $parent = $parent->parent;
  595.       }
  596.     }
  597.   }
  598.  else
  599.   {
  600.    $count = -1;
  601.    my $m2 = $menu->parent;
  602.    if ($m2->IsMenu)
  603.     {
  604.      if ($m2->cget('-type') ne 'menubar')
  605.       {
  606.        $menu->activate('none');
  607.        $menu->GenerateMenuSelect;
  608.        $m2->SetFocus;
  609.        # This code unposts any posted submenu in the parent.
  610.        my $tmp = $m2->index('active');
  611.        $m2->activate('none');
  612.        $m2->activate($tmp);
  613.        return;
  614.       }
  615.     }
  616.   }
  617.  # Can't traverse into or out of a cascaded menu. Go to the next
  618.  # or previous menubutton, if that makes sense.
  619.  
  620.  my $m2 = $menu->parent;
  621.  if ($m2->IsMenu)
  622.   {
  623.    if ($m2->cget('-type') eq 'menubar')
  624.     {
  625.      $m2->SetFocus;
  626.      $m2->NextEntry(-1);
  627.      return;
  628.     }
  629.   }
  630.  
  631.  my $w = $Tk::postedMb;
  632.  return unless defined $w;
  633.  my @buttons = $w->parent->children;
  634.  my $length = @buttons;
  635.  my $i = Tk::lsearch(\@buttons,$w)+$count;
  636.  my $mb;
  637.  while (1)
  638.   {
  639.    while ($i < 0)
  640.     {
  641.      $i += $length
  642.     }
  643.    while ($i >= $length)
  644.     {
  645.      $i += -$length
  646.     }
  647.    $mb = $buttons[$i];
  648.    last if ($mb->IsMenubutton && $mb->cget('-state') ne 'disabled'
  649.             && defined($mb->cget('-menu'))
  650.             && $mb->cget('-menu')->index('last') ne 'none'
  651.            );
  652.    return if ($mb == $w);
  653.    $i += $count
  654.   }
  655.  $mb->PostFirst();
  656. }
  657. # NextEntry --
  658. # Activate the next higher or lower entry in the posted menu,
  659. # wrapping around at the ends. Disabled entries are skipped.
  660. #
  661. # Arguments:
  662. # menu - Menu window that received the keystroke.
  663. # count - 1 means go to the next lower entry,
  664. # -1 means go to the next higher entry.
  665. sub NextEntry
  666. {
  667.  my $menu = shift;
  668.  my $count = shift;
  669.  if ($menu->index('last') eq 'none')
  670.   {
  671.    return;
  672.   }
  673.  my $length = $menu->index('last')+1;
  674.  my $quitAfter = $length;
  675.  my $active = $menu->index('active');
  676.  my $i = ($active eq 'none') ? 0 : $active+$count;
  677.  while (1)
  678.   {
  679.    return if ($quitAfter <= 0);
  680.    while ($i < 0)
  681.     {
  682.      $i += $length
  683.     }
  684.    while ($i >= $length)
  685.     {
  686.      $i += -$length
  687.     }
  688.    my $state = eval {local $SIG{__DIE__};  $menu->entrycget($i,'-state') };
  689.    last if (defined($state) && $state ne 'disabled');
  690.    return if ($i == $active);
  691.    $i += $count;
  692.    $quitAfter -= 1;
  693.   }
  694.  $menu->activate($i);
  695.  $menu->GenerateMenuSelect;
  696.  if ($menu->type($i) eq 'cascade')
  697.   {
  698.    my $cascade = $menu->entrycget($i, '-menu');
  699.    $menu->postcascade($i);
  700.    $cascade->FirstEntry if (defined $cascade);
  701.   }
  702. }
  703.  
  704.  
  705. # tkTraverseWithinMenu
  706. # This procedure implements keyboard traversal within a menu. It
  707. # searches for an entry in the menu that has "char" underlined. If
  708. # such an entry is found, it is invoked and the menu is unposted.
  709. #
  710. # Arguments:
  711. # w - The name of the menu widget.
  712. # char - The character to look for; case is
  713. # ignored. If the string is empty then
  714. # nothing happens.
  715. sub TraverseWithinMenu
  716. {
  717.  my $w = shift;
  718.  my $char = shift;
  719.  return unless (defined $char);
  720.  $char = "\L$char";
  721.  my $last = $w->index('last');
  722.  return if ($last eq 'none');
  723.  for (my $i = 0;$i <= $last;$i += 1)
  724.   {
  725.    my $label = eval {local $SIG{__DIE__};  $w->entrycget($i,'-label') };
  726.    next unless defined($label);
  727.    my $ul = $w->entrycget($i,'-underline');
  728.    if (defined $ul && $ul >= 0)
  729.     {
  730.      $label = substr("\L$label",$ul,1);
  731.      if (defined($label) && $label eq $char)
  732.       {
  733.        if ($w->type($i) eq 'cascade')
  734.         {
  735.          $w->postcascade($i);
  736.          $w->activate($i);
  737.          my $m2 = $w->entrycget($i,'-menu');
  738.          $m2->FirstEntry if (defined $m2);
  739.         }
  740.        else
  741.         {
  742.          $w->Unpost();
  743.          $w->invoke($i);
  744.         }
  745.        return;
  746.       }
  747.     }
  748.   }
  749. }
  750.  
  751. sub FindMenu
  752. {
  753.  my ($menu,$char) = @_;
  754.  if ($menu->cget('-type') eq 'menubar')
  755.   {
  756.    if (!defined($char) || $char eq '')
  757.     {
  758.      $menu->FirstEntry;
  759.     }
  760.    else
  761.     {
  762.      $menu->TraverseWithinMenu($char);
  763.     }
  764.    return $menu;
  765.   }
  766.  return undef;
  767. }
  768.  
  769.  
  770. # FirstEntry --
  771. # Given a menu, this procedure finds the first entry that isn't
  772. # disabled or a tear-off or separator, and activates that entry.
  773. # However, if there is already an active entry in the menu (e.g.,
  774. # because of a previous call to tkPostOverPoint) then the active
  775. # entry isn't changed. This procedure also sets the input focus
  776. # to the menu.
  777. #
  778. # Arguments:
  779. # menu - Name of the menu window (possibly empty).
  780. sub FirstEntry
  781. {
  782.  my $menu = shift;
  783.  return if (!defined($menu) || $menu eq '' || !ref($menu));
  784.  $menu->SetFocus;
  785.  return if ($menu->index('active') ne 'none');
  786.  my $last = $menu->index('last');
  787.  return if ($last eq 'none');
  788.  for (my $i = 0;$i <= $last;$i += 1)
  789.   {
  790.    my $state = eval {local $SIG{__DIE__};  $menu->entrycget($i,'-state') };
  791.    if (defined $state && $state ne 'disabled' && !$menu->typeIS($i,'tearoff'))
  792.     {
  793.      $menu->activate($i);
  794.      $menu->GenerateMenuSelect;
  795.      if ($menu->type($i) eq 'cascade')
  796.       {
  797.        my $cascade = $menu->entrycget($i,'-menu');
  798.        if (defined $cascade)
  799.         {
  800.          $menu->postcascade($i);
  801.          $cascade->FirstEntry;
  802.         }
  803.       }
  804.      return;
  805.     }
  806.   }
  807. }
  808.  
  809. # FindName --
  810. # Given a menu and a text string, return the index of the menu entry
  811. # that displays the string as its label. If there is no such entry,
  812. # return an empty string. This procedure is tricky because some names
  813. # like "active" have a special meaning in menu commands, so we can't
  814. # always use the "index" widget command.
  815. #
  816. # Arguments:
  817. # menu - Name of the menu widget.
  818. # s - String to look for.
  819. sub FindName
  820. {
  821.  my $menu = shift;
  822.  my $s = shift;
  823.  my $i = undef;
  824.  if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/)
  825.   {
  826.    $i = eval {local $SIG{__DIE__};  $menu->index($s) };
  827.    return $i;
  828.   }
  829.  my $last = $menu->index('last');
  830.  return if ($last eq 'none');
  831.  for ($i = 0;$i <= $last;$i += 1)
  832.   {
  833.    my $label = eval {local $SIG{__DIE__};  $menu->entrycget($i,'-label') };
  834.    return $i if (defined $label && $label eq $s);
  835.   }
  836.  return undef;
  837. }
  838. # PostOverPoint --
  839. # This procedure posts a given menu such that a given entry in the
  840. # menu is centered over a given point in the root window. It also
  841. # activates the given entry.
  842. #
  843. # Arguments:
  844. # menu - Menu to post.
  845. # x, y - Root coordinates of point.
  846. # entry - Index of entry within menu to center over (x,y).
  847. # If omitted or specified as {}, then the menu's
  848. # upper-left corner goes at (x,y).
  849. sub PostOverPoint
  850. {
  851.  my $menu = shift;
  852.  my $x = shift;
  853.  my $y = shift;
  854.  my $entry = shift;
  855.  if (defined $entry)
  856.   {
  857.    if ($entry == $menu->index('last'))
  858.     {
  859.      $y -= ($menu->yposition($entry)+$menu->height)/2;
  860.     }
  861.    else
  862.     {
  863.      $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2;
  864.     }
  865.    $x -= $menu->reqwidth/2;
  866.   }
  867.  $menu->post($x,$y);
  868.  if (defined($entry) && $menu->entrycget($entry,'-state') ne 'disabled')
  869.   {
  870.    $menu->activate($entry);
  871.    $menu->GenerateMenuSelect;
  872.   }
  873. }
  874. # tk_popup --
  875. # This procedure pops up a menu and sets things up for traversing
  876. # the menu and its submenus.
  877. #
  878. # Arguments:
  879. # menu - Name of the menu to be popped up.
  880. # x, y - Root coordinates at which to pop up the
  881. # menu.
  882. # entry - Index of a menu entry to center over (x,y).
  883. # If omitted or specified as {}, then menu's
  884. # upper-left corner goes at (x,y).
  885. sub Post
  886. {
  887.  my $menu = shift;
  888.  return unless (defined $menu);
  889.  my $x = shift;
  890.  my $y = shift;
  891.  my $entry = shift;
  892.  Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb));
  893.  $menu->PostOverPoint($x,$y,$entry);
  894.  $menu->grabGlobal;
  895.  $Tk::popup = $menu;
  896.  $Tk::focus = $menu->focusCurrent;
  897.  $menu->focus();
  898. }
  899.  
  900. sub SetFocus
  901. {
  902.  my $menu = shift;
  903.  $Tk::focus = $menu->focusCurrent if (!defined($Tk::focus));
  904.  $menu->focus;
  905. }
  906.  
  907. sub GenerateMenuSelect
  908. {
  909.  my $menu = shift;
  910.  $Tk::activeMenu = $menu;
  911.  $Tk::activeItem = $menu->index('active');
  912.  $menu->eventGenerate('<<MenuSelect>>');  # FIXME
  913. }
  914.  
  915. # Converted from tearoff.tcl --
  916. #
  917. # This file contains procedures that implement tear-off menus.
  918. #
  919. # @(#) tearoff.tcl 1.3 94/12/17 16:05:25
  920. #
  921. # Copyright (c) 1994 The Regents of the University of California.
  922. # Copyright (c) 1994 Sun Microsystems, Inc.
  923. #
  924. # See the file "license.terms" for information on usage and redistribution
  925. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  926. #
  927. # tkTearoffMenu --
  928. # Given the name of a menu, this procedure creates a torn-off menu
  929. # that is identical to the given menu (including nested submenus).
  930. # The new torn-off menu exists as a toplevel window managed by the
  931. # window manager. The return value is the name of the new menu.
  932. #
  933. # Arguments:
  934. # w - The menu to be torn-off (duplicated).
  935. sub tearOffMenu
  936. {
  937.  my $w = shift;
  938.  my $x = (@_) ? shift : 0;
  939.  my $y = (@_) ? shift : 0;
  940.  
  941.  $x = $w->rootx if $x == 0;
  942.  $y = $w->rooty if $y == 0;
  943.  
  944.  # Find a unique name to use for the torn-off menu. Find the first
  945.  # ancestor of w that is a toplevel but not a menu, and use this as
  946.  # the parent of the new menu. This guarantees that the torn off
  947.  # menu will be on the same screen as the original menu. By making
  948.  # it a child of the ancestor, rather than a child of the menu, it
  949.  # can continue to live even if the menu is deleted; it will go
  950.  # away when the toplevel goes away.
  951.  
  952.  my $parent = $w->parent;
  953.  while ($parent->toplevel != $parent || $parent->IsMenu)
  954.   {
  955.    $parent = $parent->parent;
  956.   }
  957.  my $menu = $w->clone($parent,'tearoff');
  958.  
  959.  # Pick a title for the new menu by looking at the parent of the
  960.  # original: if the parent is a menu, then use the text of the active
  961.  # entry. If it's a menubutton then use its text.
  962.  my $title = $menu->cget('-title');
  963.  unless (defined $title && length($title))
  964.   {
  965.    $parent = $w->parent;
  966.    if ($parent->IsMenubutton)
  967.     {
  968.      $title = $parent->cget('-text');
  969.     }
  970.    elsif ($parent->IsMenu)
  971.     {
  972.      $title = $parent->entrycget('active','-label');
  973.     }
  974.   }
  975.  $menu->title($title) if (defined $title && length($title));
  976.  $menu->post($x,$y);
  977.  # Set tkPriv(focus) on entry: otherwise the focus will get lost
  978.  # after keyboard invocation of a sub-menu (it will stay on the
  979.  # submenu).
  980.  $menu->bind('<Enter>','EnterFocus');
  981.  $menu->Callback('-tearoffcommand');
  982.  return $menu;
  983. }
  984.  
  985. # tkMenuDup --
  986. # Given a menu (hierarchy), create a duplicate menu (hierarchy)
  987. # in a given window.
  988. #
  989. # Arguments:
  990. # src - Source window. Must be a menu. It and its
  991. # menu descendants will be duplicated at dst.
  992. # dst - Name to use for topmost menu in duplicate
  993. # hierarchy.
  994. sub MenuDup
  995. {
  996.  my $src    = shift;
  997.  my $parent = shift;
  998.  my $type  = (@_) ? shift : 'normal';
  999.  my %args  = (-type => $type) ;
  1000.  foreach my $option ($src->configure())
  1001.   {
  1002.    next if (@$option == 2);
  1003.    $args{$$option[0]} = $$option[4] unless exists $args{$$option[0]};
  1004.   }
  1005.  my $dst = ref($src)->new($parent,%args);
  1006.  if ($type eq 'tearoff')
  1007.   {
  1008.    $dst->transient($parent->MainWindow);
  1009.   }
  1010.  my $last = $src->index('last');
  1011.  if ($last ne 'none')
  1012.   {
  1013.    for (my $i = $src->cget('-tearoff'); $i <= $last; $i++)
  1014.     {
  1015.      my $type = $src->type($i);
  1016.      if (defined $type)
  1017.       {
  1018.        my @args = ();
  1019.        foreach my $option ($src->entryconfigure($i))
  1020.         {
  1021.          next if (@$option == 2);
  1022.          push(@args,$$option[0],$$option[4]) if (defined $$option[4]);
  1023.         }
  1024.        $dst->add($type,@args);
  1025.       }
  1026.     }
  1027.   }
  1028.  # Duplicate the binding tags and bindings from the source menu.
  1029.  my @bindtags = $src->bindtags;
  1030.  my $path = $src->PathName;
  1031.  foreach (@bindtags)
  1032.   {
  1033.    $_ = $dst if ($_ eq $path);
  1034.   }
  1035.  $dst->bindtags([@bindtags]);
  1036.  foreach my $event ($src->bind)
  1037.   {
  1038.    my $cb = $src->bind($event);
  1039.    $dst->bind($event,$cb->Substitute($src,$dst));
  1040.   }
  1041.  return $dst;
  1042. }
  1043.  
  1044.  
  1045.  
  1046. # Some convenience methods
  1047.  
  1048. sub separator   { require Tk::Menu::Item; shift->Separator(@_);   }
  1049. sub cascade     { require Tk::Menu::Item; shift->Cascade(@_);     }
  1050. sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); }
  1051. sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); }
  1052.  
  1053. sub command
  1054. {
  1055.  my ($menu,%args) = @_;
  1056.  require Tk::Menu::Item;
  1057.  if (exists $args{-button})
  1058.   {
  1059.    # Backward compatible stuff from 'Menubar'
  1060.    my $button = delete $args{-button};
  1061.    $button = ['Misc', -underline => 0 ] unless (defined $button);
  1062.    my @bargs = ();
  1063.    ($button,@bargs) = @$button if (ref($button) && ref $button eq 'ARRAY');
  1064.    $menu = $menu->Menubutton(-label => $button, @bargs);
  1065.   }
  1066.  $menu->Command(%args);
  1067. }
  1068.  
  1069. sub Menubutton
  1070. {
  1071.  my ($menu,%args) = @_;
  1072.  my $name = delete($args{'-text'}) || $args{'-label'};;
  1073.  $args{'-label'} = $name if (defined $name);
  1074.  my $items = delete $args{'-menuitems'};
  1075.  foreach my $opt (qw(-pack -after -before -side -padx -ipadx -pady -ipady -fill))
  1076.   {
  1077.    delete $args{$opt};
  1078.   }
  1079.  if (defined($name) && !defined($args{-underline}))
  1080.   {
  1081.    my $underline = ($name =~ s/^(.*)~/$1/) ? length($1): undef;
  1082.    if (defined($underline) && ($underline >= 0))
  1083.     {
  1084.      $args{-underline} = $underline;
  1085.      $args{-label} = $name;
  1086.     }
  1087.   }
  1088.  my $hash = $menu->TkHash('MenuButtons');
  1089.  my $mb = $hash->{$name};
  1090.  if (defined $mb)
  1091.   {
  1092.    delete $args{'-tearoff'}; # too late!
  1093.    $mb->configure(%args) if %args;
  1094.   }
  1095.  else
  1096.   {
  1097.    $mb = $menu->cascade(%args);
  1098.    $hash->{$name} = $mb;
  1099.   }
  1100.  $mb->menu->AddItems(@$items) if defined($items) && @$items;
  1101.  return $mb;
  1102. }
  1103.  
  1104. sub BalloonInfo
  1105. {
  1106.  my ($menu,$balloon,$X,$Y,@opt) = @_;
  1107.  my $i = $menu->index('active');
  1108.  if ($i eq 'none')
  1109.   {
  1110.    my $y = $Y - $menu->rooty;
  1111.    $i = $menu->index("\@$y");
  1112.   }
  1113.  foreach my $opt (@opt)
  1114.   {
  1115.    my $info = $balloon->GetOption($opt,$menu);
  1116.    if ($opt =~ /^-(statusmsg|balloonmsg)$/ && UNIVERSAL::isa($info,'ARRAY'))
  1117.     {
  1118.      $balloon->Subclient($i);
  1119.      return '' if $i eq 'none';
  1120.      return ${$info}[$i] || '';
  1121.     }
  1122.    return $info;
  1123.   }
  1124. }
  1125.  
  1126. 1;
  1127.  
  1128. __END__
  1129.  
  1130.  
  1131.