1# -*- tcl -*- 2# 3# mentry.tcl - 4# 5# MenuEntry widget 6# 7# RCS: @(#) $Id: mentry.tcl,v 1.7 2010/06/01 18:06:52 hobbs Exp $ 8# 9 10# Creation and Options - widget::menuentry $path ... 11# -menu -default "" ; menu to associate with entry 12# -image -default "default" 13# All other options to entry 14# 15# Methods 16# All other methods to entry 17# 18# Bindings 19# NONE 20# 21 22if 0 { 23 # Samples 24 package require widget::menuentry 25 set me [widget::menuentry .me] 26 set menu [menu .me.menu -tearoff 0] 27 $menu add radiobutton -label "Name" -variable foo -value name 28 $menu add radiobutton -label "Abstract" -variable foo -value abstract 29 $menu add separator 30 $menu add radiobutton -label "Name and Abstract" \ 31 -variable foo -value [list name abstract] 32 $me configure -menu $menu 33 pack $me -fill x -expand 1 -padx 4 -pady 4 34} 35 36### 37 38package require widget 39 40namespace eval ::widget { 41 # PNG version has partial alpha transparency for better look 42 variable menuentry_pngdata { 43 iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAAACXBIWXMAAAs6 44 AAALOgFkf1cNAAACkklEQVR4nHWSXUhTYRjHdxnRVQTeCElXp7vS6BCZFGlO 45 nc2vbdrccrbhR9IKI7KOXzQniikzUvyIlNoHrZgXmYrbas6cg3keKFKoqHiC 46 VowgeC6C4PB24RmlRy/+Nw/v7/c+/5dXxRhTMcZUoqeWF73mgOi1pMBnlURP 47 vZSYNqVWJw2BlZFKPn1uezZhr8kGPktS9JjFxPQFIf7AwK1O6LnVcZ0QGzeI 48 sVFDcslVZttRIHpqefBZkmuPjU5AOgxIVYBkB6QWQCoFpENRV5kz6qpMhvs0 49 ik1Uax5zYM1tFgGJA6QmQGoDpBuAdB2QrgGSEZCyIoNaMdSnCeywQV0qMVUj 50 AFIFIN2U4VYZbgGkZkDKDzlLhHBfaUohAG+9FJ80cIB0+b9b0xWaAKkBkIyL 51 3Wou3K+VlBXcFik2puPkg3ZAuiLLGuWZFZAM8x0FXMipUQriD42p2GiVAEhq 52 GWyWYRsgXQKkOkDKm7tdIMx3FiorrIzpAysjOhGQsgBJL4NWQLLIsBaQMhe6 53 i36/aDsbVwiiw+X88n1dMjKkdQLSQUA6A0gGQNIBUi4gZUaHdX/e+O0s3Hqa 54 zdhzaxQf6dXAedvSUFky3F8qBh1FwkLnOW6uvYCbu5UvRAYqpPXnbexrYox9 55 Wr7Lgne07GnjiYwtAsaYKthTzAd7igNBpyYVcmqkoKNEmuso/LXYrWEfXvay 56 7+8esR8bbvZ+sYv5rackX/3xjC2C3TJzNc8UGaxmn18PseTbKfYldo/FJyys 57 V8199FzM2bu5hkrFtud/ybPmk6ago5xtzLaz9dlOFnXpmb+B/+k2Z+/79xi7 58 wOk8sfEmd20OW+hSM7+V/+Y2Zx9QVNgNTsdbd2z/RPURh9t8dE969hckF6c1 59 n3C8ywAAAABJRU5ErkJggg== 60 } 61 variable menuentry_gifdata { 62 R0lGODlhEAAQAPcAAAQEBIREJJpaL6RaL6RkL6RkOq9kOq9vOrpvRLp6RLqE 63 T7qPT8SPT8SaT8SaWsSaZM+kWs+kZM+vb8/k79qvetq6etq6hNrEj+TPmuTP 64 pOTapPr6+gAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 65 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 66 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 67 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 68 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 69 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 70 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 71 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 72 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 73 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 74 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 75 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 76 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 77 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 78 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA 79 AAAAAAAAAAAAAAAAAP///yH5BAEAAP8ALAAAAAAQABAAQAh4AP8JhBChIAQH 80 AhMKdIBQYcIECRRGcOhQAcWLDi5kuPAggMAIECgyYOBw4kWBFh0yWKCQAQUM 81 F1ImBECT4oAEBiSGTMiQIoSdImX+M3mSJc+TAiMqdEDSoQMJCC4qmKoggQIL 82 GjRYyCmQpleFCipUcMC160kBCQMCADs= 83 } 84} 85 86proc ::widget::createMenuEntryLayout {} { 87 variable MENUENTRY 88 if {[info exists MENUENTRY]} { return } 89 set MENUENTRY 1 90 variable menuentry_pngdata 91 variable menuentry_gifdata 92 set img ::widget::img_menuentry 93 if {[package provide img::png] != ""} { 94 image create photo $img -format PNG -data $menuentry_pngdata 95 } else { 96 image create photo $img -format GIF -data $menuentry_gifdata 97 } 98 namespace eval ::ttk [list set img $img] ; # namespace resolved 99 namespace eval ::ttk { 100 # Create -padding for space on left and right of icon 101 set pad [expr {[image width $img] + 4}] 102 style theme settings "default" { 103 style layout MenuEntry { 104 Entry.field -children { 105 MenuEntry.icon -side left 106 Entry.padding -children { 107 Entry.textarea 108 } 109 } 110 } 111 # center icon in padded cell 112 style element create MenuEntry.icon image $img \ 113 -sticky "" -padding [list $pad 0 0 0] 114 } 115 if 0 { 116 # Some mappings would be required per-theme to adapt to theme 117 # changes 118 foreach theme [style theme names] { 119 style theme settings $theme { 120 # Could have disabled, pressed, ... state images 121 #style map MenuEntry -image [list disabled $img] 122 } 123 } 124 } 125 } 126} 127 128snit::widgetadaptor widget::menuentry { 129 delegate option * to hull 130 delegate method * to hull 131 132 option -image -default "default" -configuremethod C-image 133 option -menu -default "" -configuremethod C-menu 134 135 constructor args { 136 ::widget::createMenuEntryLayout 137 138 installhull using ttk::entry -style MenuEntry 139 140 bindtags $win [linsert [bindtags $win] 1 TMenuEntry] 141 142 $self configurelist $args 143 } 144 145 method C-menu {option value} { 146 if {$value ne "" && ![winfo exists $value]} { 147 return -code error "invalid widget \"$value\"" 148 } 149 set options($option) $value 150 } 151 152 method C-image {option value} { 153 set options($option) $value 154 if {$value eq "default"} { 155 } 156 } 157} 158 159# Bindings for menu portion. 160# 161# This is a variant of the ttk menubutton.tcl bindings. 162# See menubutton.tcl for detailed behavior info. 163# 164 165namespace eval ttk { 166 bind TMenuEntry <Enter> { %W state active } 167 bind TMenuEntry <Leave> { %W state !active } 168 bind TMenuEntry <<Invoke>> { ttk::menuentry::Popdown %W %x %y } 169 bind TMenuEntry <Control-space> { ttk::menuentry::Popdown %W 10 10 } 170 171 if {[tk windowingsystem] eq "x11"} { 172 bind TMenuEntry <ButtonPress-1> { ttk::menuentry::Pulldown %W %x %y } 173 bind TMenuEntry <ButtonRelease-1> { ttk::menuentry::TransferGrab %W } 174 bind TMenuEntry <B1-Leave> { ttk::menuentry::TransferGrab %W } 175 } else { 176 bind TMenuEntry <ButtonPress-1> \ 177 { %W state pressed ; ttk::menuentry::Popdown %W %x %y } 178 bind TMenuEntry <ButtonRelease-1> { %W state !pressed } 179 } 180 181 namespace eval menuentry { 182 variable State 183 184 array set State { 185 pulldown 0 186 oldcursor {} 187 } 188 } 189} 190 191# PostPosition -- 192# Returns the x and y coordinates where the menu 193# should be posted, based on the menuentry and menu size 194# and -direction option. 195# 196# TODO: adjust menu width to be at least as wide as the button 197# for -direction above, below. 198# 199proc ttk::menuentry::PostPosition {mb menu} { 200 set x [winfo rootx $mb] 201 set y [winfo rooty $mb] 202 set dir "below" ; #[$mb cget -direction] 203 204 set bw [winfo width $mb] 205 set bh [winfo height $mb] 206 set mw [winfo reqwidth $menu] 207 set mh [winfo reqheight $menu] 208 set sw [expr {[winfo screenwidth $menu] - $bw - $mw}] 209 set sh [expr {[winfo screenheight $menu] - $bh - $mh}] 210 211 switch -- $dir { 212 above { if {$y >= $mh} { incr y -$mh } { incr y $bh } } 213 below { if {$y <= $sh} { incr y $bh } { incr y -$mh } } 214 left { if {$x >= $mw} { incr x -$mw } { incr x $bw } } 215 right { if {$x <= $sw} { incr x $bw } { incr x -$mw } } 216 flush { 217 # post menu atop menuentry. 218 # If there's a menu entry whose label matches the 219 # menuentry -text, assume this is an optionmenu 220 # and place that entry over the menuentry. 221 set index [FindMenuEntry $menu [$mb cget -text]] 222 if {$index ne ""} { 223 incr y -[$menu yposition $index] 224 } 225 } 226 } 227 228 return [list $x $y] 229} 230 231# Popdown -- 232# Post the menu and set a grab on the menu. 233# 234proc ttk::menuentry::Popdown {me x y} { 235 if {[$me instate disabled] || [set menu [$me cget -menu]] eq "" 236 || [$me identify $x $y] ne "MenuEntry.icon"} { 237 return 238 } 239 foreach {x y} [PostPosition $me $menu] { break } 240 tk_popup $menu $x $y 241} 242 243# Pulldown (X11 only) -- 244# Called when Button1 is pressed on a menuentry. 245# Posts the menu; a subsequent ButtonRelease 246# or Leave event will set a grab on the menu. 247# 248proc ttk::menuentry::Pulldown {mb x y} { 249 variable State 250 if {[$mb instate disabled] || [set menu [$mb cget -menu]] eq "" 251 || [$mb identify $x $y] ne "MenuEntry.icon"} { 252 return 253 } 254 foreach {x y} [PostPosition $mb $menu] { break } 255 set State(pulldown) 1 256 set State(oldcursor) [$mb cget -cursor] 257 258 $mb state pressed 259 $mb configure -cursor [$menu cget -cursor] 260 $menu post $x $y 261 tk_menuSetFocus $menu 262} 263 264# TransferGrab (X11 only) -- 265# Switch from pulldown mode (menuentry has an implicit grab) 266# to popdown mode (menu has an explicit grab). 267# 268proc ttk::menuentry::TransferGrab {mb} { 269 variable State 270 if {$State(pulldown)} { 271 $mb configure -cursor $State(oldcursor) 272 $mb state {!pressed !active} 273 set State(pulldown) 0 274 grab -global [$mb cget -menu] 275 } 276} 277 278# FindMenuEntry -- 279# Hack to support tk_optionMenus. 280# Returns the index of the menu entry with a matching -label, 281# -1 if not found. 282# 283proc ttk::menuentry::FindMenuEntry {menu s} { 284 set last [$menu index last] 285 if {$last eq "none"} { 286 return "" 287 } 288 for {set i 0} {$i <= $last} {incr i} { 289 if {![catch {$menu entrycget $i -label} label] 290 && ($label eq $s)} { 291 return $i 292 } 293 } 294 return "" 295} 296 297package provide widget::menuentry 1.0.1 298