tkgoodstuff/tcl/Menu.tcl

210 lines
6.3 KiB
Tcl
Raw Normal View History

# Menu Client Tcl code for tkgoodstuff
# format of menu: list of items:
# 0:type 1:label 2:list of switches 3:list of children for cascades
proc MenuDeclare {} {
set Prefs_taborder(:Clients,Menu) "Menu Misc Button"
TKGDeclare Menu(makebutton) 1 -typelist [list Clients Menu Button Misc]\
-label "Produce a button (otherwise Menu 1 is bound to clock)"\
-vartype boolean
TKGDeclare Menu(text) "Menu" -typelist [list Clients Menu Button Misc]\
-label "Text on button"
TKGDeclare Menu(balloon) "" \
-typelist [list Clients Menu Button Misc]\
-label "Text of balloon help"
TKGDeclare Menu(imagefile) {%tkgmenu} -typelist [list Clients Menu Button Misc]\
-label "Image on Button (file)"
TKGDeclare Menu(iconside) background -typelist [list Clients Menu Button Misc] \
-label {Side of icon on button} -vartype optionMenu\
-optionlist {left right top bottom background}
TKGDeclare Menu(ignore) 1 \
-label {Ignore general preferences for no labels and no icons} \
-vartype boolean -typelist [list Clients Menu Button Misc]
ConfigDeclare TkMan ClientButton1 TkMan [list Clients TkMan Button]
TKGDeclare Menu(font) ""\
-vartype font\
-typelist [list Clients Menu Button Misc]\
-label "Font on button" -help "Leave blank for a default that depends on the tkgoodstuff\
font scale."
if [Empty $Menu(font)] {
# set Menu(font) "Times [lindex {14 18 24} $TKG(fontscale)] bold"
set Menu(font) tkghugebold
}
TKGDeclare Menu(tearoff) 0 -typelist [list Clients Menu Misc]\
-label "Make tear-off menus" -vartype boolean
ConfigDeclare Menu ClientButton3 Menu [list Clients Menu Button]
set mdata [list \
[list Menu Applications {} [list \
[list Exec Rxvt [list -command rxvt]]\
[list Exec Emacs [list -command emacs]]\
[list Exec Knews [list -command knews]]\
[list Exec Netscape [list -command netscape]]\
[list Exec XV [list -command xv]]\
]]\
[list Separator "-------"]\
[list Menu Utilities {} [list \
[list Exec tkdesk]\
[list Exec xdir]\
[list Exec tkman]\
[list Exec xfontsel]\
[list Exec xcolorsel]\
[list Exec "TkCon" [list -command tkcon.tcl]]\
]]\
[list Separator "-------"]\
[list Run "Run . . ."]\
[list Separator "-------"]\
[list TKGMenu "tkgoodstuff Menu"]\
]
TKGDeclare Menu(data) $mdata\
-typelist [list Clients Menu Menu]\
-vartype menu -nolabel 1 -nodefault 1
unset mdata
}
proc MenuCreateWindow {} {
global MenuClient-params Menu
if {![TKGReGrid MenuClient] && ![info exists Menu(current)]} {
if $Menu(makebutton) {
lappend c TKGMakeButton MenuClient \
-menu .menu\
-foreground $Menu(foreground) \
-background $Menu(background) \
-activeforeground $Menu(activeforeground) \
-activebackground $Menu(activebackground) \
-font $Menu(font) -ignore $Menu(ignore)
foreach v {text imagefile balloon iconside} {
if ![Empty $Menu($v)] {
lappend c -$v $Menu($v)
}
}
eval $c
set button [set MenuClient-params(pathname)]
set Menu(current) $button.menu
menu $Menu(current) -tearoff $Menu(tearoff)
$button configure -menu $Menu(current)
} else {
global Clock
set Clock(menu) .menu
set Menu(current) .menu
}
set Menu(counter) 0
foreach item $Menu(data) {
Menu[lindex $item 0] $item
}
}
}
proc MenuMenu {item} {
set label [lindex $item 1]
global Menu
set m $Menu(current).[incr Menu(counter)]
menu $m -tearoff $Menu(tearoff)
$Menu(current) add cascade -label $label -menu $m
set Menu(parent,$m) $Menu(current)
set Menu(current) $m
foreach child [lindex $item 3] {
Menu[lindex $child 0] $child
}
set Menu(current) $Menu(parent,$Menu(current))
}
proc MenuExec {item} {
global Menu
set label [lindex $item 1]
set switches [lindex $item 2]
set command [lindex $switches [expr [lsearch $switches -command] +1]]
if {$command == ""} {set command $label}
set command [SelectionSub $command]
$Menu(current) add command -label $label -command [list MenuDoExec $command]
}
proc MenuDoExec {command} {
global Fvwm
if {[info exists Fvwm(outid)] && [string match Fvwm* $command]} {
lappend C fvwm send 0 "Module $command"
} else {
lappend C eval exec $command &
}
if [catch $C err] {
error $err
}
}
proc MenuTcl {item} {
global Menu
set label [lindex $item 1]
set switches [lindex $item 2]
set command [lindex $switches [expr [lsearch $switches -command] +1]]
if {$command == ""} {set command $label}
set command [SelectionSub $command]
$Menu(current) add command -label $label -command $command
}
proc MenuRun {item} {
global Menu
$Menu(current) add command -label "Run . . ." -command TKGRun
}
proc MenuTKGMenu {item} {
global Menu
set m $Menu(current).tkgpopup
$Menu(current) add cascade -label "TkGoodStuff menu" \
-menu $m
menu $m -tearoff $Menu(tearoff) -postcommand "TKGMenuDup .tkgpopup $m"
}
proc MenuSeparator {item} {
global Menu
$Menu(current) add separator
}
proc TKGRun {} {
TKGDialog tkgrun -wmtitle "Run . . ." -title "Run . . ."\
-buttons [list [list ok OK {eval exec $TKGRun_command &;destroy .tkgrun}]]
grid [entry .tkgrun.entry -width 40 -textvariable TKGRun_command]\
-row 5 -column 0 -sticky nsew
focus .tkgrun.entry
bind .tkgrun.entry <Key-Return> {
.tkgrun.buttons.ok flash
.tkgrun.buttons.ok invoke
break
}
}
# a slightly modified version of tkMenuDup in tearoff.tcl
proc TKGMenuDup {src dst} {
set cmd "$dst configure"
foreach option [$src configure] {
if {[llength $option] == 2} {
continue
}
lappend cmd [lindex $option 0] [lindex $option 4]
}
eval $cmd
set last [$src index last]
if {$last == "none"} {
return
}
for {set i [$src cget -tearoff]} {$i <= $last} {incr i} {
set cmd "$dst add [$src type $i]"
foreach option [$src entryconfigure $i] {
lappend cmd [lindex $option 0] [lindex $option 4]
}
eval $cmd
if {[$src type $i] == "cascade"} {
tkMenuDup [$src entrycget $i -menu] $dst.m$i normal
$dst entryconfigure $i -menu $dst.m$i
}
}
regsub -all . $src {\\&} quotedSrc
regsub -all . $dst {\\&} quotedDst
regsub -all $quotedSrc [bindtags $src] $dst x
bindtags $dst $x
foreach event [bind $src] {
regsub -all $quotedSrc [bind $src $event] $dst x
bind $dst $event $x
}
}
DEBUG "Loaded Menu.tcl"