mingw/lib/tk8.4/tearoff.tcl

   1 # tearoff.tcl --
   2 #
   3 # This file contains procedures that implement tear-off menus.
   4 #
   5 # RCS: @(#) $Id: tearoff.tcl,v 1.7.4.1 2006/01/25 18:21:41 dgp 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     }
  41
  42     set parent [winfo parent $w]
  43     while {[winfo toplevel $parent] ne $parent || [winfo class $parent] eq "Menu"} {
  44         set parent [winfo parent $parent]
  45     }
  46     if {$parent eq "."} {
  47         set parent ""
  48     }
  49     for {set i 1} 1 {incr i} {
  50         set menu $parent.tearoff$i
  51         if {![winfo exists $menu]} {
  52             break
  53         }
  54     }
  55
  56     $w clone $menu tearoff
  57
  58     # Pick a title for the new menu by looking at the parent of the
  59     # original: if the parent is a menu, then use the text of the active
  60     # entry.  If it's a menubutton then use its text.
  61
  62     set parent [winfo parent $w]
  63     if {[$menu cget -title] ne ""} {
  64         wm title $menu [$menu cget -title]
  65     } else {
  66         switch [winfo class $parent] {
  67             Menubutton {
  68                 wm title $menu [$parent cget -text]
  69             }
  70             Menu {
  71                 wm title $menu [$parent entrycget active -label]
  72             }
  73         }
  74     }
  75
  76     $menu post $x $y
  77
  78     if {[winfo exists $menu] == 0} {
  79         return ""
  80     }
  81
  82     # Set tk::Priv(focus) on entry:  otherwise the focus will get lost
  83     # after keyboard invocation of a sub-menu (it will stay on the
  84     # submenu).
  85
  86     bind $menu <Enter> {
  87         set tk::Priv(focus) %W
  88     }
  89
  90     # If there is a -tearoffcommand option for the menu, invoke it
  91     # now.
  92
  93     set cmd [$w cget -tearoffcommand]
  94     if {$cmd ne ""} {
  95         uplevel #0 $cmd [list $w $menu]
  96     }
  97     return $menu
  98 }
  99
 100 # ::tk::MenuDup --
 101 # Given a menu (hierarchy), create a duplicate menu (hierarchy)
 102 # in a given window.
 103 #
 104 # Arguments:
 105 # src -                 Source window.  Must be a menu.  It and its
 106 #                       menu descendants will be duplicated at dst.
 107 # dst -                 Name to use for topmost menu in duplicate
 108 #                       hierarchy.
 109
 110 proc ::tk::MenuDup {src dst type} {
 111     set cmd [list menu $dst -type $type]
 112     foreach option [$src configure] {
 113         if {[llength $option] == 2} {
 114             continue
 115         }
 116         if {[lindex $option 0] eq "-type"} {
 117             continue
 118         }
 119         lappend cmd [lindex $option 0] [lindex $option 4]
 120     }
 121     eval $cmd
 122     set last [$src index last]
 123     if {$last eq "none"} {
 124         return
 125     }
 126     for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
 127         set cmd [list $dst add [$src type $i]]
 128         foreach option [$src entryconfigure $i]  {
 129             lappend cmd [lindex $option 0] [lindex $option 4]
 130         }
 131         eval $cmd
 132     }
 133
 134     # Duplicate the binding tags and bindings from the source menu.
 135
 136     set tags [bindtags $src]
 137     set srcLen [string length $src]
 138
 139     # Copy tags to x, replacing each substring of src with dst.
 140
 141     while {[set index [string first $src $tags]] != -1} {
 142         append x [string range $tags 0 [expr {$index - 1}]]$dst
 143         set tags [string range $tags [expr {$index + $srcLen}] end]
 144     }
 145     append x $tags
 146
 147     bindtags $dst $x
 148
 149     foreach event [bind $src] {
 150         unset x
 151         set script [bind $src $event]
 152         set eventLen [string length $event]
 153
 154         # Copy script to x, replacing each substring of event with dst.
 155
 156         while {[set index [string first $event $script]] != -1} {
 157             append x [string range $script 0 [expr {$index - 1}]]
 158             append x $dst
 159             set script [string range $script [expr {$index + $eventLen}] end]
 160         }
 161         append x $script
 162
 163         bind $dst $event $x
 164     }
 165 }