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