home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / Tk / Menu.pm < prev    next >
Encoding:
Perl POD Document  |  1997-08-10  |  21.0 KB  |  787 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. use AutoLoader;
  21.  
  22. @ISA = qw(Tk::Wm Tk::Derived Tk::Widget);
  23.  
  24. Construct Tk::Widget 'Menu';
  25.  
  26. bootstrap Tk::Menu $Tk::VERSION;
  27.  
  28. sub Tk_cmd { \&Tk::menu }
  29.  
  30. import Tk qw(Ev);
  31.  
  32. sub CreateArgs
  33. {
  34.  my ($package,$parent,$args) = @_;
  35.  # Remove from hash %$args any configure-like
  36.  # options which only apply at create time (e.g. -class for Frame)
  37.  # return these as a list of -key => value pairs
  38.  my @result = ();
  39.  my $opt;
  40.  foreach $opt (qw(-screen -visual -colormap))
  41.   {
  42.    my $val = delete $args->{$opt};                     
  43.    push(@result, $opt => $val) if (defined $val);
  44.   }
  45.  return @result;
  46. }
  47.  
  48. sub InitObject
  49. {
  50.  my ($menu,$args) = @_;
  51.  my $menuitems = delete $args->{-menuitems};
  52.  $menu->SUPER::InitObject($args);
  53.  if (defined $menuitems)
  54.   {
  55.    # If any other args do configure now
  56.    if (%$args)
  57.     {
  58.      $menu->configure(%$args);
  59.      %$args = ();
  60.     }
  61.    $menu->AddItems(@$menuitems) 
  62.   }
  63. }
  64.  
  65. sub AddItems
  66. {
  67.  require Tk::Menu::Item;
  68.  my $menu = shift;
  69.  ITEM:
  70.  while (@_)
  71.   {
  72.    my $item = shift;
  73.    if (!ref($item))
  74.     { 
  75.      $menu->separator;  # A separator
  76.     }  
  77.    else
  78.     {
  79.      my ($kind,$name,%minfo) = ( @$item );
  80.      my $invoke = delete $minfo{'-invoke'};
  81.      if (defined $name)
  82.       {
  83.        $minfo{-label} = $name unless defined($minfo{-label});
  84.        $menu->$kind(%minfo);
  85.       }
  86.      else
  87.       {
  88.        $menu->BackTrace("Don't recognize " . join(' ',@$item));
  89.       }
  90.     }  # A non-separator
  91.   }
  92. }
  93.         
  94. 1;
  95.  
  96. __END__
  97.  
  98. #
  99. #-------------------------------------------------------------------------
  100. # Elements of tkPriv that are used in this file:
  101. #
  102. # cursor - Saves the -cursor option for the posted menubutton.
  103. # focus - Saves the focus during a menu selection operation.
  104. # Focus gets restored here when the menu is unposted.
  105. # inMenubutton - The name of the menubutton widget containing
  106. # the mouse, or an empty string if the mouse is
  107. # not over any menubutton.
  108. # popup - If a menu has been popped up via tk_popup, this
  109. # gives the name of the menu. Otherwise this
  110. # value is empty.
  111. # postedMb - Name of the menubutton whose menu is currently
  112. # posted, or an empty string if nothing is posted
  113. # A grab is set on this widget.
  114. # relief - Used to save the original relief of the current
  115. # menubutton.
  116. # window - When the mouse is over a menu, this holds the
  117. # name of the menu; it's cleared when the mouse
  118. # leaves the menu.
  119. #-------------------------------------------------------------------------
  120. #-------------------------------------------------------------------------
  121. # Overall note:
  122. # This file is tricky because there are four different ways that menus
  123. # can be used:
  124. #
  125. # 1. As a pulldown from a menubutton. This is the most common usage.
  126. # In this style, the variable tkPriv(postedMb) identifies the posted
  127. # menubutton.
  128. # 2. As a torn-off menu copied from some other menu. In this style
  129. # tkPriv(postedMb) is empty, and the top-level menu is no
  130. # override-redirect.
  131. # 3. As an option menu, triggered from an option menubutton. In thi
  132. # style tkPriv(postedMb) identifies the posted menubutton.
  133. # 4. As a popup menu. In this style tkPriv(postedMb) is empty and
  134. # the top-level menu is override-redirect.
  135. #
  136. # The various binding procedures use the state described above to
  137. # distinguish the various cases and take different actions in each
  138. # case.
  139. #-------------------------------------------------------------------------
  140. # Bind --
  141. # This procedure is invoked the first time the mouse enters a menubutton
  142. # widget or a menubutton widget receives the input focus. It creates
  143. # all of the class bindings for both menubuttons and menus.
  144. #
  145. # Arguments:
  146. # w - The widget that was just entered or just received
  147. # the input focus.
  148. # event - Indicates which event caused the procedure to be invoked
  149. # (Enter or FocusIn). It is used so that we can carry out
  150. # the functions of that event in addition to setting up
  151. # bindings.
  152. sub ClassInit
  153. {
  154.  my ($class,$mw) = @_;
  155.  # Must set focus when mouse enters a menu, in order to allow
  156.  # mixed-mode processing using both the mouse and the keyboard.
  157.  $mw->bind($class,"<Enter>", 'Enter');
  158.  $mw->bind($class,"<Leave>", ['Leave',Ev(X),Ev(Y),Ev('s')]);
  159.  $mw->bind($class,"<Motion>", ['Motion',Ev('y'),Ev('s')]);
  160.  $mw->bind($class,"<ButtonPress>",'ButtonDown');
  161.  $mw->bind($class,"<ButtonRelease>",'Invoke');
  162.  $mw->bind($class,"<space>",'Invoke');
  163.  $mw->bind($class,"<Return>",'Invoke');
  164.  $mw->bind($class,"<Escape>",'Escape');
  165.  $mw->bind($class,"<Left>",['LeftRight',"left"]);
  166.  $mw->bind($class,"<Right>",['LeftRight',"right"]);
  167.  $mw->bind($class,"<Up>",['NextEntry',-1]);
  168.  $mw->bind($class,"<Down>",['NextEntry',1]);
  169.  $mw->bind($class,"<KeyPress>", ['TraverseWithinMenu',Ev(A)]);
  170.  return $class;
  171. }
  172.  
  173. # Unpost --
  174. # This procedure unposts a given menu, plus all of its ancestors up
  175. # to (and including) a menubutton, if any. It also restores various
  176. # values to what they were before the menu was posted, and releases
  177. # a grab if there's a menubutton involved. Special notes:
  178. # 1. It's important to unpost all menus before releasing the grab, so
  179. # that any Enter-Leave events (e.g. from menu back to main
  180. # application) have mode NotifyGrab.
  181. # 2. Be sure to enclose various groups of commands in "catch" so that
  182. # the procedure will complete even if the menubutton or the menu
  183. # or the grab window has been deleted.
  184. #
  185. # Arguments:
  186. # menu - Name of a menu to unpost. Ignored if there
  187. # is a posted menubutton.
  188. sub Unpost
  189. {
  190.  my $menu = shift;
  191.  my $mb = $Tk::postedMb;
  192.  
  193.  # Restore focus right away (otherwise X will take focus away when
  194.  # the menu is unmapped and under some window managers (e.g. olvwm)
  195.  # we'll lose the focus completely).
  196.  
  197.  eval {local $SIG{__DIE__}; $Tk::focus->focus() } if (defined $Tk::focus);
  198.  undef $Tk::focus;
  199.  
  200.  # Unpost menu(s) and restore some stuff that's dependent on
  201.  # what was posted.
  202.  eval {local $SIG{__DIE__}; 
  203.    if (defined $mb)
  204.      {
  205.       $menu = $mb->cget("-menu");
  206.       $menu->unpost();
  207.       $Tk::postedMb = undef;
  208.       $mb->configure("-cursor",$Tk::cursor);
  209.       $mb->configure("-relief",$Tk::relief)
  210.      }
  211.     elsif (defined $Tk::popup)
  212.      {
  213.       $Tk::popup->unpost();
  214.       undef $Tk::popup;
  215.      }
  216.     elsif (defined $menu && ref $menu && $menu->overrideredirect)
  217.      {
  218.       # We're in a cascaded sub-menu from a torn-off menu or popup.
  219.       # Unpost all the menus up to the toplevel one (but not
  220.       # including the top-level torn-off one) and deactivate the
  221.       # top-level torn off menu if there is one.
  222.       while (1)
  223.        {
  224.         $parent = $menu->parent;
  225.         last if (!$parent->IsMenu || !$parent->ismapped);
  226.         $parent->postcascade("none");
  227.         last if (!$parent->overrideredirect);
  228.         $menu = $parent
  229.        }
  230.       $menu->unpost()
  231.      }
  232.   };
  233.  warn "$@" if ($@);
  234.  # Release grab, if any.
  235.  if (defined $menu && ref $menu)
  236.   {
  237.    my $grab = $menu->grabCurrent;
  238.    $grab->grabRelease if (defined $grab);
  239.   }
  240. }
  241.  
  242. sub typeIS
  243. {my $w = shift;
  244.  my $type = $w->type(shift);
  245.  return defined $type && $type eq shift;
  246. }
  247.  
  248. # Motion --
  249. # This procedure is called to handle mouse motion events for menus.
  250. # It does two things. First, it resets the active element in the
  251. # menu, if the mouse is over the menu.  Second, if a mouse button
  252. # is down, it posts and unposts cascade entries to match the mouse
  253. # position.
  254. #
  255. # Arguments:
  256. # menu - The menu window.
  257. # y - The y position of the mouse.
  258. # state - Modifier state (tells whether buttons are down).
  259. sub Motion
  260. {
  261.  my $menu = shift;
  262.  my $y = shift;
  263.  my $state = shift;
  264.  if ($menu->IS($Tk::window))
  265.   {
  266.    $menu->activate("\@$y")
  267.   }
  268.  if (($state & 0x1f00) != 0)
  269.   {
  270.    $menu->postcascade("active")
  271.   }
  272. }
  273. # ButtonDown --
  274. # Handles button presses in menus. There are a couple of tricky things
  275. # here:
  276. # 1. Change the posted cascade entry (if any) to match the mouse position.
  277. # 2. If there is a posted menubutton, must grab to the menubutton so
  278. #    that it can track mouse motions over other menubuttons and change
  279. #    the posted menu.
  280. # 3. If there's no posted menubutton (e.g. because we're a torn-off menu
  281. #    or one of its descendants) must grab to the top-level menu so that
  282. #    we can track mouse motions across the entire menu hierarchy.
  283.  
  284. #
  285. # Arguments:
  286. # menu - The menu window.
  287. sub ButtonDown
  288. {
  289.  my $menu = shift;
  290.  $menu->postcascade("active");
  291.  if (defined $Tk::postedMb)
  292.   {
  293.    $Tk::postedMb->grabGlobal
  294.   }
  295.  else
  296.   {
  297.    while ($menu->overrideredirect
  298.           && $menu->parent->IsMenu
  299.           && $menu->parent->ismapped 
  300.          )
  301.     {
  302.      $menu = $menu->parent;
  303.     }
  304.    $menu->grabGlobal;
  305.   }
  306. }
  307.  
  308. sub Enter
  309. {
  310.  my $w = shift; 
  311.  $Tk::window = $w; 
  312.  $w->focus();
  313. }
  314.  
  315. # Leave --
  316. # This procedure is invoked to handle Leave events for a menu. It
  317. # deactivates everything unless the active element is a cascade element
  318. # and the mouse is now over the submenu.
  319. #
  320. # Arguments:
  321. # menu - The menu window.
  322. # rootx, rooty - Root coordinates of mouse.
  323. # state - Modifier state.
  324. sub Leave
  325. {
  326.  my $menu = shift;
  327.  my $rootx = shift;
  328.  my $rooty = shift;
  329.  my $state = shift;
  330.  my $type;
  331.  undef $Tk::window;
  332.  return if ($menu->index("active") eq "none");
  333.  return if ! defined $menu->Containing($rootx,$rooty);
  334.  return if ($menu->typeIS("active","cascade") && 
  335.             $menu->entrycget("active","-menu")->IS($menu->Containing($rootx,$rooty)));
  336.  $menu->activate("none")
  337. }
  338. # Invoke --
  339. # This procedure is invoked when button 1 is released over a menu.
  340. # It invokes the appropriate menu action and unposts the menu if
  341. # it came from a menubutton.
  342. #
  343. # Arguments:
  344. # w - Name of the menu widget.
  345. sub Invoke
  346. {
  347.  my $w = shift;
  348.  my $type = $w->type("active");
  349.  if ($w->typeIS("active","cascade"))
  350.   {
  351.    $w->postcascade("active");
  352.    $menu = $w->entrycget("active","-menu");
  353.    $menu->FirstEntry() if (defined $menu);
  354.   }
  355.  elsif ($w->typeIS("active","tearoff"))
  356.   {
  357.    $w->Unpost();
  358.    $w->TearOffMenu();
  359.   }
  360.  else
  361.   {
  362.    $w->Unpost();
  363.    $w->invoke("active")
  364.   }
  365. }
  366. # Escape --
  367. # This procedure is invoked for the Cancel (or Escape) key. It unposts
  368. # the given menu and, if it is the top-level menu for a menu button,
  369. # unposts the menu button as well.
  370. #
  371. # Arguments:
  372. # menu - Name of the menu window.
  373. sub Escape
  374. {
  375.  my $menu = shift;
  376.  if (!$menu->parent->IsMenu)
  377.   {
  378.    $menu->Unpost()
  379.   }
  380.  else
  381.   {
  382.    $menu->LeftRight(-1)
  383.   }
  384. }
  385. # LeftRight --
  386. # This procedure is invoked to handle "left" and "right" traversal
  387. # motions in menus. It traverses to the next menu in a menu bar,
  388. # or into or out of a cascaded menu.
  389. #
  390. # Arguments:
  391. # menu - The menu that received the keyboard
  392. # event.
  393. # direction - Direction in which to move: "left" or "right"
  394. sub LeftRight
  395. {
  396.  my $menu = shift;
  397.  my $direction = shift;
  398.  # First handle traversals into and out of cascaded menus.
  399.  if ($direction eq "right")
  400.   {
  401.    $count = 1;
  402.    if ($menu->typeIS("active","cascade"))
  403.     {
  404.      $menu->postcascade("active");
  405.      $m2 = $menu->entrycget("active","-menu");
  406.      $m2->FirstEntry if (defined $m2);
  407.      return;
  408.     }
  409.   }
  410.  else
  411.   {
  412.    $count = -1;
  413.    $m2 = $menu->parent;
  414.    if ($m2->IsMenu)
  415.     {
  416.      $menu->activate("none");
  417.      $m2->focus();
  418.      # This code unposts any posted submenu in the parent.
  419.      $tmp = $m2->index("active");
  420.      $m2->activate("none");
  421.      $m2->activate($tmp);
  422.      return;
  423.     }
  424.   }
  425.  # Can't traverse into or out of a cascaded menu. Go to the next
  426.  # or previous menubutton, if that makes sense.
  427.  $w = $Tk::postedMb;
  428.  if ($w eq "")
  429.   {
  430.    return;
  431.   }
  432.  my @buttons = $w->parent->children;
  433.  $length = @buttons;
  434.  $i = Tk::lsearch(\@buttons,$w)+$count;
  435.  while (1)
  436.   {
  437.    while ($i < 0)
  438.     {
  439.      $i += $length
  440.     }
  441.    while ($i >= $length)
  442.     {
  443.      $i += -$length
  444.     }
  445.    $mb = $buttons[$i];
  446.    last if ($mb->IsMenubutton && $mb->cget("-state") ne "disabled"
  447.             && defined($mb->cget('-menu'))
  448.             && $mb->cget('-menu')->index('last') ne 'none'
  449.            );
  450.    return if ($mb == $w);
  451.    $i += $count
  452.   }
  453.  $mb->PostFirst();
  454. }
  455. # NextEntry --
  456. # Activate the next higher or lower entry in the posted menu,
  457. # wrapping around at the ends. Disabled entries are skipped.
  458. #
  459. # Arguments:
  460. # menu - Menu window that received the keystroke.
  461. # count - 1 means go to the next lower entry,
  462. # -1 means go to the next higher entry.
  463. sub NextEntry
  464. {
  465.  my $menu = shift;
  466.  my $count = shift;
  467.  if ($menu->index("last") eq "none")
  468.   {
  469.    return;
  470.   }
  471.  $length = $menu->index("last")+1;
  472.  $active = $menu->index("active");
  473.  if ($active eq "none")
  474.   {
  475.    $i = 0
  476.   }
  477.  else
  478.   {
  479.    $i = $active+$count
  480.   }
  481.  while (1)
  482.   {
  483.    while ($i < 0)
  484.     {
  485.      $i += $length
  486.     }
  487.    while ($i >= $length)
  488.     {
  489.      $i += -$length
  490.     }
  491.    $state = eval {local $SIG{__DIE__};  $menu->entrycget($i,"-state") };
  492.    last if (defined($state) && $state ne "disabled");
  493.    return if ($i == $active);
  494.    $i += $count
  495.   }
  496.  $menu->activate($i);
  497.  $menu->postcascade($i)
  498. }
  499.  
  500.  
  501. # tkTraverseWithinMenu
  502. # This procedure implements keyboard traversal within a menu. It
  503. # searches for an entry in the menu that has "char" underlined. If
  504. # such an entry is found, it is invoked and the menu is unposted.
  505. #
  506. # Arguments:
  507. # w - The name of the menu widget.
  508. # char - The character to look for; case is
  509. # ignored. If the string is empty then
  510. # nothing happens.
  511. sub TraverseWithinMenu
  512. {
  513.  my $w = shift;
  514.  my $char = shift;
  515.  return unless (defined $char);
  516.  $char = "\L$char";
  517.  my $last = $w->index("last");
  518.  return if ($last eq "none");
  519.  for ($i = 0;$i <= $last;$i += 1)
  520.   {
  521.    my $label = eval {local $SIG{__DIE__};  $w->entrycget($i,"-label") };
  522.    next unless defined($label);
  523.    my $ul = $w->entrycget($i,"-underline");
  524.    if (defined $ul && $ul >= 0)
  525.     {
  526.      $label = substr("\L$label",$ul,1);
  527.      if (defined($label) && $label eq $char)
  528.       {
  529.        if ($w->type($i) eq 'cascade')
  530.         {
  531.          $w->postcascade($i);
  532.          $w->activate($i);
  533.          my $m2 = $w->entrycget($i,'-menu');
  534.          $m2->FirstEntry if (defined $m2);
  535.         }
  536.        else
  537.         {
  538.          $w->Unpost();  
  539.          $w->invoke($i);
  540.         }
  541.        return;
  542.       }
  543.     }
  544.   }
  545. }
  546. # FirstEntry --
  547. # Given a menu, this procedure finds the first entry that isn't
  548. # disabled or a tear-off or separator, and activates that entry.
  549. # However, if there is already an active entry in the menu (e.g.,
  550. # because of a previous call to tkPostOverPoint) then the active
  551. # entry isn't changed. This procedure also sets the input focus
  552. # to the menu.
  553. #
  554. # Arguments:
  555. # menu - Name of the menu window (possibly empty).
  556. sub FirstEntry
  557. {
  558.  my $menu = shift;
  559.  return if (!defined($menu) || $menu eq "" || !ref($menu));
  560.  $menu->Enter;
  561.  return if ($menu->index("active") ne "none");
  562.  $last = $menu->index("last");
  563.  return if ($last eq 'none');
  564.  for ($i = 0;$i <= $last;$i += 1)
  565.   {
  566.    my $state = eval {local $SIG{__DIE__};  $menu->entrycget($i,"-state") };
  567.    if (defined $state && $state ne "disabled" && !$menu->typeIS($i,"tearoff"))
  568.     {
  569.      $menu->activate($i);
  570.      return;
  571.     }
  572.   }
  573. }
  574.  
  575. # FindName --
  576. # Given a menu and a text string, return the index of the menu entry
  577. # that displays the string as its label. If there is no such entry,
  578. # return an empty string. This procedure is tricky because some names
  579. # like "active" have a special meaning in menu commands, so we can't
  580. # always use the "index" widget command.
  581. #
  582. # Arguments:
  583. # menu - Name of the menu widget.
  584. # s - String to look for.
  585. sub FindName
  586. {
  587.  my $menu = shift;
  588.  my $s = shift;
  589.  my $i = undef;
  590.  if ($s !~ /^active$|^last$|^none$|^[0-9]|^@/)
  591.   {
  592.    $i = eval {local $SIG{__DIE__};  $menu->index($s) };
  593.    return $i;
  594.   }
  595.  my $last = $menu->index("last");
  596.  return if ($last eq 'none');
  597.  for ($i = 0;$i <= $last;$i += 1)
  598.   {
  599.    my $label = eval {local $SIG{__DIE__};  $menu->entrycget($i,"-label") };
  600.    return $i if (defined $label && $label eq $s);
  601.   }
  602.  return undef;
  603. }
  604. # PostOverPoint --
  605. # This procedure posts a given menu such that a given entry in the
  606. # menu is centered over a given point in the root window. It also
  607. # activates the given entry.
  608. #
  609. # Arguments:
  610. # menu - Menu to post.
  611. # x, y - Root coordinates of point.
  612. # entry - Index of entry within menu to center over (x,y).
  613. # If omitted or specified as {}, then the menu's
  614. # upper-left corner goes at (x,y).
  615. sub PostOverPoint
  616. {
  617.  my $menu = shift;
  618.  my $x = shift;
  619.  my $y = shift;
  620.  my $entry = shift;
  621.  if (defined $entry)
  622.   {
  623.    if ($entry == $menu->index("last"))
  624.     {
  625.      $y -= ($menu->yposition($entry)+$menu->height)/2;
  626.     }
  627.    else
  628.     {
  629.      $y -= ($menu->yposition($entry)+$menu->yposition($entry+1))/2;
  630.     }
  631.    $x -= $menu->reqwidth/2;
  632.   }
  633.  $menu->post($x,$y);
  634.  if (defined($entry) && $menu->entrycget($entry,"-state") ne "disabled")
  635.   {
  636.    $menu->activate($entry)
  637.   }
  638. }
  639. # tk_popup --
  640. # This procedure pops up a menu and sets things up for traversing
  641. # the menu and its submenus.
  642. #
  643. # Arguments:
  644. # menu - Name of the menu to be popped up.
  645. # x, y - Root coordinates at which to pop up the
  646. # menu.
  647. # entry - Index of a menu entry to center over (x,y).
  648. # If omitted or specified as {}, then menu's
  649. # upper-left corner goes at (x,y).
  650. sub Post
  651. {
  652.  my $menu = shift;
  653.  return unless (defined $menu);
  654.  my $x = shift;
  655.  my $y = shift;
  656.  my $entry = shift;
  657.  Unpost(undef) if (defined($Tk::popup) || defined($Tk::postedMb));
  658.  $menu->PostOverPoint($x,$y,$entry);
  659.  $menu->grabGlobal;
  660.  $Tk::popup = $menu;
  661.  $Tk::focus = $menu->focusCurrent;
  662.  $menu->focus();
  663. }
  664.  
  665. # Converted from tearoff.tcl --
  666. #
  667. # This file contains procedures that implement tear-off menus.
  668. #
  669. # @(#) tearoff.tcl 1.3 94/12/17 16:05:25
  670. #
  671. # Copyright (c) 1994 The Regents of the University of California.
  672. # Copyright (c) 1994 Sun Microsystems, Inc.
  673. #
  674. # See the file "license.terms" for information on usage and redistribution
  675. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  676. #
  677. # tkTearoffMenu --
  678. # Given the name of a menu, this procedure creates a torn-off menu
  679. # that is identical to the given menu (including nested submenus).
  680. # The new torn-off menu exists as a toplevel window managed by the
  681. # window manager. The return value is the name of the new menu.
  682. #
  683. # Arguments:
  684. # w - The menu to be torn-off (duplicated).
  685. sub TearOffMenu
  686. {
  687.  my $w = shift;
  688.  # Find a unique name to use for the torn-off menu. Find the first
  689.  # ancestor of w that is a toplevel but not a menu, and use this as
  690.  # the parent of the new menu. This guarantees that the torn off
  691.  # menu will be on the same screen as the original menu. By making
  692.  # it a child of the ancestor, rather than a child of the menu, it
  693.  # can continue to live even if the menu is deleted; it will go
  694.  # away when the toplevel goes away.
  695.  my $parent = $w->parent;
  696.  while ($parent->toplevel != $parent || $parent->IsMenu)
  697.   {
  698.    $parent = $parent->parent;
  699.   }
  700.  my $menu = $w->MenuDup($parent);
  701.  # $menu->overrideredirect(0);
  702.  $menu->configure(-transient => 0);
  703.  $menu->transient($parent);
  704.  # Pick a title for the new menu by looking at the parent of the
  705.  # original: if the parent is a menu, then use the text of the active
  706.  # entry. If it's a menubutton then use its text.
  707.  $parent = $w->parent;
  708.  if ($parent->IsMenubutton)
  709.   {
  710.    $menu->title($parent->cget("-text"))
  711.   }
  712.  elsif ($parent->IsMenu)
  713.   {
  714.    $menu->title($parent->entrycget("active","-label"))
  715.   }
  716.  $menu->configure("-tearoff",0);
  717.  $menu->post($w->x,$w->y);
  718.  # Set tkPriv(focus) on entry: otherwise the focus will get lost
  719.  # after keyboard invocation of a sub-menu (it will stay on the
  720.  # submenu).
  721.  $menu->bind("<Enter>",EnterFocus);
  722.  $menu->Callback('-tearoffcommand');
  723. }
  724.  
  725. # tkMenuDup --
  726. # Given a menu (hierarchy), create a duplicate menu (hierarchy)
  727. # in a given window.
  728. #
  729. # Arguments:
  730. # src - Source window. Must be a menu. It and its
  731. # menu descendants will be duplicated at dst.
  732. # dst - Name to use for topmost menu in duplicate
  733. # hierarchy.
  734. sub MenuDup
  735. {
  736.  my $src    = shift;
  737.  my $parent = shift;
  738.  my @args   = ();
  739.  my $option;
  740.  foreach $option ($src->configure())
  741.   {
  742.    next if (@$option == 2);
  743.    push(@args,$$option[0],$$option[4]);
  744.   }
  745.  my $dst = $parent->Menu(@args);
  746.  my $last = $src->index("last");
  747.  return if ($last eq 'none');
  748.  my $i;
  749.  for ($i = $src->cget("-tearoff");$i <= $last;$i += 1)
  750.   {
  751.    my $type = $src->type($i);
  752.    if (defined $type)
  753.     {
  754.      @args = ();
  755.      foreach $option ($src->entryconfigure($i))
  756.       {
  757.        next if (@$option == 2);
  758.        push(@args,$$option[0],$$option[4]) if (defined $$option[4]);
  759.       }
  760.      $dst->add($type,@args);
  761.      if ($type eq "cascade")
  762.       {
  763.        my $srcm = $src->entrycget($i,"-menu");
  764.        if (defined $srcm)
  765.         {
  766.          $dst->entryconfigure($i,"-menu",$srcm->MenuDup($dst));
  767.         }
  768.       }
  769.      elsif ($type eq "checkbutton" || $type eq "radiobutton")
  770.       {
  771.        $dst->entryconfigure($i,"-variable",$src->entrycget($i,"-variable"));
  772.       }
  773.     }
  774.   }
  775.  return $dst;
  776. }
  777.  
  778. # Some convenience methods 
  779.  
  780. sub separator   { require Tk::Menu::Item; shift->Separator(@_);   }
  781. sub command     { require Tk::Menu::Item; shift->Command(@_);     }
  782. sub cascade     { require Tk::Menu::Item; shift->Cascade(@_);     }
  783. sub checkbutton { require Tk::Menu::Item; shift->Checkbutton(@_); }
  784. sub radiobutton { require Tk::Menu::Item; shift->Radiobutton(@_); }
  785.  
  786. 1; 
  787.