home *** CD-ROM | disk | FTP | other *** search
/ CD Actual Thematic 7: Programming / CDAT7.iso / Share / Editores / Perl5 / perl / lib / site / auto / Tk / Menu / TearOffMenu.al < prev    next >
Encoding:
Text File  |  1997-08-10  |  2.2 KB  |  65 lines
  1. # NOTE: Derived from ..\blib\lib\Tk\Menu.pm.  Changes made here will be lost.
  2. package Tk::Menu;
  3.  
  4. # Converted from tearoff.tcl --
  5. #
  6. # This file contains procedures that implement tear-off menus.
  7. #
  8. # @(#) tearoff.tcl 1.3 94/12/17 16:05:25
  9. #
  10. # Copyright (c) 1994 The Regents of the University of California.
  11. # Copyright (c) 1994 Sun Microsystems, Inc.
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16. # tkTearoffMenu --
  17. # Given the name of a menu, this procedure creates a torn-off menu
  18. # that is identical to the given menu (including nested submenus).
  19. # The new torn-off menu exists as a toplevel window managed by the
  20. # window manager. The return value is the name of the new menu.
  21. #
  22. # Arguments:
  23. # w - The menu to be torn-off (duplicated).
  24. sub TearOffMenu
  25. {
  26.  my $w = shift;
  27.  # Find a unique name to use for the torn-off menu. Find the first
  28.  # ancestor of w that is a toplevel but not a menu, and use this as
  29.  # the parent of the new menu. This guarantees that the torn off
  30.  # menu will be on the same screen as the original menu. By making
  31.  # it a child of the ancestor, rather than a child of the menu, it
  32.  # can continue to live even if the menu is deleted; it will go
  33.  # away when the toplevel goes away.
  34.  my $parent = $w->parent;
  35.  while ($parent->toplevel != $parent || $parent->IsMenu)
  36.   {
  37.    $parent = $parent->parent;
  38.   }
  39.  my $menu = $w->MenuDup($parent);
  40.  # $menu->overrideredirect(0);
  41.  $menu->configure(-transient => 0);
  42.  $menu->transient($parent);
  43.  # Pick a title for the new menu by looking at the parent of the
  44.  # original: if the parent is a menu, then use the text of the active
  45.  # entry. If it's a menubutton then use its text.
  46.  $parent = $w->parent;
  47.  if ($parent->IsMenubutton)
  48.   {
  49.    $menu->title($parent->cget("-text"))
  50.   }
  51.  elsif ($parent->IsMenu)
  52.   {
  53.    $menu->title($parent->entrycget("active","-label"))
  54.   }
  55.  $menu->configure("-tearoff",0);
  56.  $menu->post($w->x,$w->y);
  57.  # Set tkPriv(focus) on entry: otherwise the focus will get lost
  58.  # after keyboard invocation of a sub-menu (it will stay on the
  59.  # submenu).
  60.  $menu->bind("<Enter>",EnterFocus);
  61.  $menu->Callback('-tearoffcommand');
  62. }
  63.  
  64. 1;
  65.