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