mingw/lib/tk8.5/tearoff.tcl

   1 # tearoff.tcl --
   2 #
   3 # This file contains procedures that implement tear-off menus.
   4 #
   5 # RCS: @(#) $Id: tearoff.tcl,v 1.11 2007/04/23 21:16:43 das Exp $
   6 #
   7 # Copyright (c) 1994 The Regents of the University of California.
   8 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
   9 #
  10 # See the file "license.terms" for information on usage and redistribution
  11 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12 #
  13
  14 # ::tk::TearoffMenu --
  15 # Given the name of a menu, this procedure creates a torn-off menu
  16 # that is identical to the given menu (including nested submenus).
  17 # The new torn-off menu exists as a toplevel window managed by the
  18 # window manager.  The return value is the name of the new menu.
  19 # The window is created at the point specified by x and y
  20 #
  21 # Arguments:
  22 # w -                   The menu to be torn-off (duplicated).
  23 # x -                   x coordinate where window is created
  24 # y -                   y coordinate where window is created
  25
  26 proc ::tk::TearOffMenu {w {x 0} {y 0}} {
  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
  35     if {$x == 0} {
  36         set x [winfo rootx $w]
  37     }
  38     if {$y == 0} {
  39         set y [winfo rooty $w]
  40         if {[tk windowingsystem] eq "aqua"} {
  41             # Shift by height of tearoff entry minus height of window titlebar
  42             catch {incr y [expr {[$w yposition 1] - 16}]}
  43             # Avoid the native menu bar which sits on top of everything.
  44             if {$y < 22} { set y 22 }
  45         }
  46     }
  47
  48     set parent [winfo parent $w]
  49     while {[winfo toplevel $parent] ne $parent \
  50             || [winfo class $parent] eq "Menu"} {
  51         set parent [winfo parent $parent]
  52     }
  53     if {$parent eq "."} {
  54         set parent ""
  55     }
  56     for {set i 1} 1 {incr i} {
  57         set menu $parent.tearoff$i
  58         if {![winfo exists $menu]} {
  59             break
  60         }
  61     }
  62
  63     $w clone $menu tearoff
  64
  65     # Pick a title for the new menu by looking at the parent of the
  66     # original: if the parent is a menu, then use the text of the active
  67     # entry.  If it's a menubutton then use its text.
  68
  69     set parent [winfo parent $w]
  70     if {[$menu cget -title] ne ""} {
  71         wm title $menu [$menu cget -title]
  72     } else {
  73         switch -- [winfo class $parent] {
  74             Menubutton {
  75                 wm title $menu [$parent cget -text]
  76             }
  77             Menu {
  78                 wm title $menu [$parent entrycget active -label]
  79             }
  80         }
  81     }
  82
  83     $menu post $x $y
  84
  85     if {[winfo exists $menu] == 0} {
  86         return ""
  87     }
  88
  89     # Set tk::Priv(focus) on entry:  otherwise the focus will get lost
  90     # after keyboard invocation of a sub-menu (it will stay on the
  91     # submenu).
  92
  93     bind $menu <Enter> {
  94         set tk::Priv(focus) %W
  95     }
  96
  97     # If there is a -tearoffcommand option for the menu, invoke it
  98     # now.
  99
 100     set cmd [$w cget -tearoffcommand]
 101     if {$cmd ne ""} {
 102         uplevel #0 $cmd [list $w $menu]
 103     }
 104     return $menu
 105 }
 106
 107 # ::tk::MenuDup --
 108 # Given a menu (hierarchy), create a duplicate menu (hierarchy)
 109 # in a given window.
 110 #
 111 # Arguments:
 112 # src -                 Source window.  Must be a menu.  It and its
 113 #                       menu descendants will be duplicated at dst.
 114 # dst -                 Name to use for topmost menu in duplicate
 115 #                       hierarchy.
 116
 117 proc ::tk::MenuDup {src dst type} {
 118     set cmd [list menu $dst -type $type]
 119     foreach option [$src configure] {
 120         if {[llength $option] == 2} {
 121             continue
 122         }
 123         if {[lindex $option 0] eq "-type"} {
 124             continue
 125         }
 126         lappend cmd [lindex $option 0] [lindex $option 4]
 127     }
 128     eval $cmd
 129     set last [$src index last]
 130     if {$last eq "none"} {
 131         return
 132     }
 133     for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
 134         set cmd [list $dst add [$src type $i]]
 135         foreach option [$src entryconfigure $i]  {
 136             lappend cmd [lindex $option 0] [lindex $option 4]
 137         }
 138         eval $cmd
 139     }
 140
 141     # Duplicate the binding tags and bindings from the source menu.
 142
 143     set tags [bindtags $src]
 144     set srcLen [string length $src]
 145
 146     # Copy tags to x, replacing each substring of src with dst.
 147
 148     while {[set index [string first $src $tags]] != -1} {
 149         append x [string range $tags 0 [expr {$index - 1}]]$dst
 150         set tags [string range $tags [expr {$index + $srcLen}] end]
 151     }
 152     append x $tags
 153
 154     bindtags $dst $x
 155
 156     foreach event [bind $src] {
 157         unset x
 158         set script [bind $src $event]
 159         set eventLen [string length $event]
 160
 161         # Copy script to x, replacing each substring of event with dst.
 162
 163         while {[set index [string first $event $script]] != -1} {
 164             append x [string range $script 0 [expr {$index - 1}]]
 165             append x $dst
 166             set script [string range $script [expr {$index + $eventLen}] end]
 167         }
 168         append x $script
 169
 170         bind $dst $event $x
 171     }
 172 }