1# -*-mode: tcl; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
2#
3#       $Id: Wmenu.tcl,v 1.8 2004-10-13 12:08:58 vvzhy Exp $
4#
5###### wmenu.tcl ######
6############################################################
7# Netmath       Copyright (C) 1998 William F. Schelter     #
8# For distribution under GNU public License.  See COPYING. #
9############################################################
10
11# implement a menu bar without toplevel windows.
12# wet
13
14proc wmenubar { name  } {
15    if { "[string index $name 0]" == "." } {
16	frame $name
17	# puts "rename $name $name-orig"
18	rename $name $name-orig
19	set top [winfo toplevel $name]
20	oset $top helpwin ""
21	proc $name { option args } "wmenubarInternal $name \$option \$args"
22	set parent [winfo parent $name]
23	# maybe change this to do traversal toward side leaving on..
24	oset $name items ""
25    } else {
26	error [mc "needs a window name arg"]
27    }
28}
29
30
31proc eswitch { key lis } {
32    foreach {k act} $lis { lappend allowd $k}
33    lappend lis default [concat [mc "error"] "$key" [mc "must be one of:"] "$allowd"]
34    uplevel 1 switch -- $key  [list  $lis]
35}
36
37proc ogetr { win var dflt } {
38    set w $win
39    while { 1 } {
40	if { 0 == [catch { set val [oget $w $var] }] } {
41	    return $val
42	}
43	global [oarray $w]
44	# puts w=$w,[array get [oarray $w]]
45	set w [winfo parent $w]
46	if { "$w" == "" } {return $dflt}
47    }
48}
49
50proc deleteHelp { win } {
51    #mike FIXME: This is being called even if show_balloons = 0
52    linkLocal $win helpPending
53    if { [info exists  helpPending] } {
54	after cancel $helpPending
55	unset helpPending
56    }
57    set top [winfo toplevel $win]
58    set helpwin [oget $top helpwin]
59    if {$helpwin != "" && [winfo exists $helpwin]} {
60	place forget $helpwin
61    }
62}
63
64proc setHelp {win  help args } {
65    # set c [ogetr $win c "cant"]
66    if { "$help" == "" } {set help [concat [mc "This is a menu window"] "$win"]}
67    set enter ""
68    set exit ""
69    if  { [catch { set current [$win cget -relief] } ] || "$current" \
70	    != "flat" } {
71	set enter ""
72	set exit ""
73    } else {
74	set enter "$win configure -relief raised" ;
75	set exit "$win configure -relief $current"
76    }
77    # puts "current=$current"
78
79    bind $win <Enter> "$enter; showHelp $win  {$help} $args"
80    bind $win <Leave> "$exit; deleteHelp $win"
81}
82
83
84#
85#-----------------------------------------------------------------
86#
87# showHelp --  for WINDOW show a HELP message using ANCHOR positions.
88#  WINDOW may be a window or a rectangle specifier: x,y,wid,height
89#  ANCHOR positions may be either n,w,e,s,nw,ne,se,sw,center or
90#  one of these followed by two floating point numbers indicating
91#  the fraction of the width and height of the window one is away from
92#  the upper left x,y of the window.
93#  Results: none
94#
95#  Side Effects: display a window.
96#
97#----------------------------------------------------------------
98#
99proc showHelp { win help args } {
100    global show_balloons helpwin
101    if { $show_balloons == 0 } {
102	#mike FIXME: $win is a list not a window
103	set top [winfo toplevel [lindex $win 0]]
104	set helpwin [oget $top helpwin]
105	if {$helpwin != "" && [winfo exists $helpwin]} {
106	    place forget $helpwin
107	}
108	return
109    }
110    linkLocal [lindex $win 0] helpPending
111    #mike FIXME: $win is a list not a window - needs an eval
112    set helpPending [after 1000 [list showHelp1 $win $help $args]]
113}
114
115proc showHelp1 { win help args } {
116    global  tk_version
117    set top [winfo toplevel [lindex $win 0]]
118    #    set anchors $args
119    #    append anchors "  w  e s ne n sw nw"
120    #    set anchors " nw"
121    #    set anchors "w e n {nw .2 1.2} {ne .8 1.2} s se"
122    #     set anchors "w e n {nw .2 1.2} {ne .8 1.2} s se"
123    set anchors "sw w e n {nw .2 1.2} {ne .8 1.2} s se"
124    makeLocal $top helpwin
125    if { "$helpwin" == "" } {
126	set tt $top
127	if { "$tt" == "." } {set tt ""}
128	set helpwin $tt.balloonhelpwin
129	if { ![winfo exists $helpwin] } {
130
131	    label $helpwin -width 0 -height 0  -borderwidth 1 \
132		    -background beige -padx 4 -pady 4 -justify left
133	}
134	$helpwin config -relief solid
135
136	oset $top helpwin $helpwin
137    }
138    if { [string first _eval $help ] == 0 } {
139	catch { set help [eval [concat list [lindex $help 1]]]}
140    }
141
142    $helpwin configure -text $help \
143	-wraplength [expr {round(.34 * [winfo width $top])}]
144    global anchorPositions
145    if { [llength $win] == 5 } {
146	desetq "win wx wy wxdim wydim" $win
147    }  else {
148	set wx [expr {[winfo rootx $win ] - [winfo rootx $top]}]
149	set wy [expr {[winfo rooty $win ] - [winfo rooty $top]}]
150	set wxdim [winfo width $win]
151	set wydim [winfo height $win]
152    }
153    set nxdim [winfo reqwidth $helpwin]
154    set nydim [winfo reqheight $helpwin]
155    set topxdim  [winfo width $top]
156    set topydim  [winfo height $top]
157    global anchorPositions
158    foreach an $anchors {
159	if {[llength $an] == 3} {
160	    desetq "an rx ry" $an
161	} else {
162	    desetq "rx ry" [lsublis { {0 1.1 } {1 -.1}} $anchorPositions($an)]
163	}
164	# puts "rx=$rx,ry=$ry"
165	set yoff [expr { $ry > 1 ? 8 : $ry < 0 ? -8 : 0 } ]
166	desetq "x y" [getPlaceCoords 0 $yoff $rx $ry $an $wx $wy $wxdim $wydim $nxdim $nydim]
167	# puts "for $win $an rx=$rx,ry=$ry x=$x,y=$y :[expr {$x >5}],[expr {$y > 5}],[expr {$x+$nxdim < $topxdim}],[expr {$y +$nydim < $topydim}]"
168	if { $x > 5 && $y > 5 && $x+$nxdim < $topxdim && \
169		$y +$nydim < $topydim } {
170	    place forget $helpwin
171
172    	    place $helpwin -x $x -y $y -anchor nw
173	    after idle raise $helpwin
174	    return
175	}
176    }
177}
178
179proc wmenubarInternal { win  option  lis } {
180    # puts "{wmenubarInternal $win $option $lis}"
181    set key [lindex $lis 0]
182    set lis [lrange $lis 1 end]
183    eswitch $option {
184	add {
185	    set parent [winfo parent $win]
186	    if { "$parent" == "."} {set parent ""}
187	    set men [assoc -menu $lis $parent.item[llength [oget $win items]]]
188 	    bindAltForUnderline $key "wmenuPost $key"
189	    frame $men -relief raised -borderwidth 2p
190	    setHelp $key [assoc -help $lis] n nw ne
191	    rename $men $men-orig
192	    set body "wmenuInternal $key \$option \$args"
193	    proc $men {option args } $body
194	    pack $key -in $win -side left -expand 0 -fill both
195	    global [oarray $win]
196	    lappend [oloc $win items] $key
197	    oset $key menu $men
198	    oset $men items ""
199	    oset $key parent $win
200	    bind $key <Button-1>  {wmenuPost %W}
201	    return $men
202	}
203	configure {
204	    return [eval $win-orig configure $key $lis]
205
206	}
207	invoke {
208	    set w [lindex [oget $win items] $key]
209	    wmenuPost $w
210	}
211	cget {
212	    return [eval $win cget $key $lis]
213	}
214    }
215}
216
217proc getSomeOpts { opts lis } {
218    set answer ""
219    foreach {ke val } $lis {
220	if { [lsearch $opts $ke] >= 0  } {
221	    lappend answer $ke $val
222	}
223    }
224    return $answer
225}
226
227proc excludeSomeOpts { opts lis } {
228    set answer ""
229    foreach {ke val } $lis {
230	if { [lsearch $opts $ke] < 0  } {
231	    lappend answer $ke $val
232	}
233    }
234    return $answer
235}
236
237proc lsublis { subs lis } {
238    foreach v $subs {
239	set key [lindex $v 0]
240	while { [set i [lsearch $lis $key]] >= 0 } {
241	    if { [llength $v] > 1 } {
242		set lis [lreplace $lis $i $i [lindex $v 1]]
243	    } else {
244		set lis [lreplace $lis $i $i]
245	    }
246	}
247    }
248    return $lis
249}
250
251proc wmenuInternal {win option  olist } {
252    set key [lindex $olist 0]
253    set lis [lrange $olist 1 end]
254    makeLocal $win menu parent
255    makeLocal $menu items
256    eswitch $option {
257	add {
258	    if { [catch {set counter [oget $menu counter] }] }   {
259		set counter 0
260	    }
261	    oset $menu counter [incr counter]
262	    # set new to be the new menu item window
263	    # set com to be the command for 'invoke' to invoke.
264	    set opts [excludeSomeOpts "-textvariable -image -label -underline -help" $lis]
265	    set labopts [lsublis {{-label -text}} \
266		    [getSomeOpts "-image -label -textvariable -underline" $lis]]
267	    append labopts " -justify left -anchor w -padx 2"
268	    eswitch $key {
269		radio {
270		    set new $menu.fr$counter
271		    frame $new -borderwidth 1
272		    # puts "new=$new"
273		    apply label $new.label $labopts
274		    pack $new.label -side left -fill x
275		    set opts [lsublis {{-radiovariable -textvariable}} $opts]
276		    apply radiobutton $new.radio $opts
277		    pack $new.radio -side right -anchor e
278		    set com "$new.radio invoke"
279		}
280		check {
281		    set new $menu.fr$counter
282		    frame $new -borderwidth 1
283		    # puts "new=$new"
284		    apply label $new.label $labopts
285		    pack $new.label -side left
286		    set opts [lsublis {{-checkvariable -textvariable}} $opts]
287		    apply checkbutton $new.check $opts
288		    pack $new.check -side right
289		    # puts "$var --> $val"
290		    set com "$new.check invoke"
291		}
292		command {
293		    set com [assoc -command $lis]
294		    set new $menu.fr$counter
295		    frame $new -borderwidth 1
296		    apply label $new.label $labopts
297		    pack $new.label -in $new -side left
298		    # puts "bind $new.label <Button-1> $com"
299		    bind $new.label <Button-1> $com
300		    bind $new <Button-1> $com
301		}
302		window {
303		    set new [assoc -window $lis]
304		    set com [assoc -command $lis list]
305		}
306		entry {
307		    set new $menu.fr$counter
308		    frame $new -borderwidth 1
309		    apply label $new.label $labopts
310		    set opts [lsublis {{-entryvariable -textvariable}} $opts]
311		    apply entry $new.entry $opts
312		    pack $new.label -side top -in $new -anchor w
313		    pack $new.entry  -side top -in $new
314		    set com "focus $new.entry"
315		}
316		separator {
317		    set new $menu.sep$counter
318		    frame $new -height 4
319		    propagate $new 0
320		    set com ""
321		}
322
323	    }
324	    bindAltForUnderline $new.label "$menu invoke $new"
325	    pack $new -in $menu -side top -fill both -expand 0
326	    oset $menu items [lappend items $new]
327	    oset $menu command$new $com
328	    setHelp $new [assoc -help $lis] w e
329	    return $new
330	}
331	configure {
332	    return [eval $win configure $key $lis]
333	}
334	invoke {
335	    makeLocal $menu items
336	    if { ![winfo exists $key] }  {
337		# it is an index
338		set key [lindex $items $key]
339	    }
340	    eval [oget $menu command$key]
341	    return
342	}
343	post {
344
345	    place $menu -anchor nw -relx 0 -rely 0 -bordermode outside -in $win
346	    bind $menu <Leave> "place forget $menu"
347	    focus $menu
348	    #bind $menu <FocusIn> "puts focus in"
349	    #bind $menu <FocusOut> "puts {leave for focus  menu}"
350	    raise $menu
351	}
352    }
353}
354
355proc wmenuPost { win } {
356    makeLocal $win parent menu
357    bind $menu <Leave> "place forget $menu"
358    place $menu -anchor nw -relx 0 -rely 1.0 -bordermode outside -in $win
359    raise $menu
360}
361
362proc bindAltForUnderline { item command } {
363    set ind -1
364    catch { set ind [$item cget -underline] }
365    if { $ind >= 0 } {
366	set letter [string index [$item cget -text] $ind]
367	set to [winfo toplevel $item]
368	bind $to <Alt-Key-$letter> $command
369    }
370}
371
372proc showSomeEvents { win } {
373    foreach v { Enter FocusIn FocusOut Visibility Leave} {
374	bind $win <$v> "puts {$win $v %x %y}"
375    }
376}
377
378global anchorPositions
379array set anchorPositions {
380    n {.5 0} nw { 0 0 } se {1 1} e {1 .5} center {.5 .5}
381    s { .5 1} sw { 0 1} w { 0 .5} ne { 0 1}
382}
383
384proc getPlaceCoords { x y relx rely anchor xIn yIn xdimIn ydimIn xdim ydim } {
385    global anchorPositions
386
387    # puts "xIn=$xIn,yIn=$yIn,xdimIn=$xdimIn,ydimIn=$ydimIn,xdim=$xdim,ydim=$ydim"
388    set x1 [expr {$x + $xIn+$relx * $xdimIn}]
389    set y1 [expr {$y + $yIn+$rely * $ydimIn}]
390    desetq "fx1 fy1" $anchorPositions($anchor)
391    set atx [expr {$x1 - $fx1*$xdim}]
392    set aty [expr {$y1 - $fy1*$ydim}]
393
394    return [list $atx $aty]
395}
396
397## endsource wmenu.tcl
398