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.4.1 2010/01/03 01:17:48 patthoyts 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     if {[tk windowingsystem] eq "win32"} {
  84         wm transient $menu [winfo toplevel $parent]
  85         wm attributes $menu -toolwindow 1
  86     }
  87
  88     $menu post $x $y
  89
  90     if {[winfo exists $menu] == 0} {
  91         return ""
  92     }
  93
  94     # Set tk::Priv(focus) on entry:  otherwise the focus will get lost
  95     # after keyboard invocation of a sub-menu (it will stay on the
  96     # submenu).
  97
  98     bind $menu <Enter> {
  99         set tk::Priv(focus) %W
 100     }
 101
 102     # If there is a -tearoffcommand option for the menu, invoke it
 103     # now.
 104
 105     set cmd [$w cget -tearoffcommand]
 106     if {$cmd ne ""} {
 107         uplevel #0 $cmd [list $w $menu]
 108     }
 109     return $menu
 110 }
 111
 112 # ::tk::MenuDup --
 113 # Given a menu (hierarchy), create a duplicate menu (hierarchy)
 114 # in a given window.
 115 #
 116 # Arguments:
 117 # src -                 Source window.  Must be a menu.  It and its
 118 #                       menu descendants will be duplicated at dst.
 119 # dst -                 Name to use for topmost menu in duplicate
 120 #                       hierarchy.
 121
 122 proc ::tk::MenuDup {src dst type} {
 123     set cmd [list menu $dst -type $type]
 124     foreach option [$src configure] {
 125         if {[llength $option] == 2} {
 126             continue
 127         }
 128         if {[lindex $option 0] eq "-type"} {
 129             continue
 130         }
 131         lappend cmd [lindex $option 0] [lindex $option 4]
 132     }
 133     eval $cmd
 134     set last [$src index last]
 135     if {$last eq "none"} {
 136         return
 137     }
 138     for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
 139         set cmd [list $dst add [$src type $i]]
 140         foreach option [$src entryconfigure $i]  {
 141             lappend cmd [lindex $option 0] [lindex $option 4]
 142         }
 143         eval $cmd
 144     }
 145
 146     # Duplicate the binding tags and bindings from the source menu.
 147
 148     set tags [bindtags $src]
 149     set srcLen [string length $src]
 150
 151     # Copy tags to x, replacing each substring of src with dst.
 152
 153     while {[set index [string first $src $tags]] != -1} {
 154         append x [string range $tags 0 [expr {$index - 1}]]$dst
 155         set tags [string range $tags [expr {$index + $srcLen}] end]
 156     }
 157     append x $tags
 158
 159     bindtags $dst $x
 160
 161     foreach event [bind $src] {
 162         unset x
 163         set script [bind $src $event]
 164         set eventLen [string length $event]
 165
 166         # Copy script to x, replacing each substring of event with dst.
 167
 168         while {[set index [string first $event $script]] != -1} {
 169             append x [string range $script 0 [expr {$index - 1}]]
 170             append x $dst
 171             set script [string range $script [expr {$index + $eventLen}] end]
 172         }
 173         append x $script
 174
 175         bind $dst $event $x
 176     }
 177 }