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