figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

tearoff.tcl (5142B)


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