#---------------------------------------------------------*-tcl-*------
#
# psmenu.tcl
# Framework for building Tk menu structure
#
# Copyright (c) 2024, Peter Spjuth (peter.spjuth@gmail.com)
#
# Permission is granted to use this code under the same terms as
# for the Tcl core code.
#
#----------------------------------------------------------------------
# This is used as a Tcl Module. Use it like this:
# ::tcl::tm::path add <path-to-dir-with-module>
# package require psmenu
# psmenu::psmenu . {
# definitions...
# }
#----------------------------------------------------------------------
package provide psmenu 1.1
namespace eval psmenu {
namespace export psmenu
}
set psmenu::example {
# All definition blocks are lists.
# Thus \-newline are not strictly necessary.
# For compactness, options are kept short
# -ul for -underline
# "&File"-syntax supported for label
# -var for -variable
# Variable is initialised if not existing
# If used with cascade, store menu widget in var
# -cfgvar Store entryconfigure command in var
# -cmd for -command
# command part is put through "subst"
# -acc for -accelerator
# Will bind <Key-acc> to command unless -accelerator
# -def for default value of -var
# checkbuttons default to default 0
# radiobuttons default to first value seen
# if/else commands can be included
package require psmenu
psmenu::psmenu . {
# Comments are ok
# If an argument looks like a "body" this is a cascade
"&File" {
"&Copy Solver URL" -cmd copySolverUrl
# Separator is --*
--------------------
"&Quit" -cmd exit
}
"&Config" {
"&Rules" -var ::mooa {
"Knight" -var ::ruleset(knight) -cmd changeRuleSet
"King" -var ::ruleset(king) -cmd changeRuleSet
"No Consecutive" -var ::ruleset(consecutive) -cmd changeRuleSet
"Grid Size" -var mooo {
# TBD allow loops?
# Define a bunch of radiobuttons at once.
# Without -value it is same as label string
_Radio -var ::ruleset(gridsize) -cmd newGame -def 9 {
"8" -value 8
"9" -value 9
"10"
}
# Individual example
"6" -value 6 -var ::ruleset(gridsize) -cmd newGame
}
}
# checkbutton has a -var and possibly -cmd, -onvalue, -offvalue
"Conflict Check" -var ::uiData(conflict) -cmd autoConflict
}
}
# More calls with more cascades work
psmenu::psmenu . {
"&Debug" {
"Reread &Source" -acc F1 -cmd _rs
}
}
}
##nagelfar syntax psmenu::PopEntry v
##nagelfar syntax tk::AmpMenuArgs x*
# Main call for psmenu. Some optional arguments are for internal use.
# Canbe called with an existing menu, but then -top must be given.
proc psmenu::psmenu {top args} {
set def [lindex $args end]
set args [lrange $args 0 end-1]
set opts(-top) ""
set opts(-level) ""
set opts(-level) ""
set opts(-recursive) 0
array set opts $args
# Is given arg a toplevel or menu?
if {$top eq "."} {
set m .m
} else {
if {[winfo class $top] ne "Menu"} {
set m $top.m
} else {
# A menu was given, assume -top
set m $top
set top $opts(-top)
}
}
if {$opts(-recursive)} {
# Locate a free window name for the menu, for internal call
while {[winfo exists $m]} {
if {[regexp {^(.*?)(\d+)$} $m -> prefix Index]} {
incr Index
} else {
set prefix $m
set Index 0
}
set m $prefix$Index
}
}
# It might exist for a second user call
if { ! [winfo exists $m]} {
# Create
menu $m -tearoff 0
}
if {$opts(-level) eq ""} {
# Store initial level to handle scope when recursing cascades
set opts(-level) [uplevel 1 info level]
}
if {$opts(-top) eq ""} {
set opts(-top) $top
$top configure -menu $m
}
# Comments in definition block
set def [regsub -all -line {^\s*#.*$} $def ""]
set state ""
while {[llength $def] > 0} {
#puts "Def length [llength $def]"; update
set entry [PopEntry def]
set label [lindex $entry 0]
if {$label eq "_Radio"} {
set options [lrange $entry 1 end-1]
set body [lindex $entry end]
set radioDef {}
for {set t 0} {$t < [llength $body]} {incr t} {
set label [lindex $body $t]
if {[lindex $body $t+1] eq "-value"} {
incr t 2
set value [lindex $body $t]
} else {
set value $label
}
lappend radioDef $label -value $value {*}$options
}
#puts "RADIO '$radioDef'"
# Prepend
set def [list {*}$radioDef {*}$def]
# TBD FIXA
continue
}
# Conditionals
if {$label eq "if"} {
# TBD support elseif
set ifExpr [lindex $entry 1]
set body [lindex $entry 2]
set elseBody [lindex $entry 4]
set cond [uplevel \#$opts(-level) [list expr $ifExpr]]
#puts "if expression '$ifExpr' = $cond"
if {$cond} {
# Prepend
set def [list {*}$body {*}$def]
} elseif {$elseBody ne ""} {
set def [list {*}$elseBody {*}$def]
}
continue
}
# Recognise Cascade by even args "Name ?opts? Def"
# An item will be "Name ?opts?", i.e odd
if {[llength $entry] % 2 == 0} {
# Cascade
set options [lrange $entry 1 end-1]
set body [lindex $entry end]
# Recurse cascade defintion
set cascade [psmenu $m {*}[array get opts] -recursive 1 $body]
# Since -menu is last, processing below can assume that.
lappend options -menu $cascade
} else {
set options [lrange $entry 1 end]
}
#puts "Label '$label'"
#puts "Options '$options'"
# Figure out type
if {[string match "-*" $label]} {
set type separator
set label ""
} elseif {[dict exists $options -menu]} {
set type "cascade"
} elseif {[dict exists $options -value]} {
set type radiobutton
} elseif {[dict exists $options -var]} {
set type checkbutton
} else {
set type command
}
# Process options
set newOptions {}
if {$label ne ""} {
lappend newOptions -label $label
}
set doBind ""
set command ""
set value ""
set variable ""
set cfgvar ""
set default 0
foreach {opt val} $options {
set val [uplevel \#$opts(-level) [list subst $val]]
switch -- $opt {
-ul - -underline {
lappend newOptions -underline $val
}
-var - -variable {
if {$type eq "cascade"} {
set variable $val
} else {
set variable $val
lappend newOptions -variable $val
}
}
-cfgvar {
set cfgvar $val
}
-cmd - -command {
set command $val
lappend newOptions -command $val
}
-acc {
lappend newOptions -accelerator $val
set doBind $val
}
-accelerator {
lappend newOptions -accelerator $val
}
-value {
lappend newOptions -value $val
set default $val
}
-offvalue {
lappend newOptions -offvalue $val
set default $val
}
-onvalue {
lappend newOptions -onvalue $val
}
-menu {
lappend newOptions -menu $val
if {$variable ne ""} {
uplevel \#$opts(-level) [list set $variable $val]
}
}
-def {
set default $val
}
default {
# Just let through
lappend newOptions $opt $val
}
}
}
if {$variable ne ""} {
##nagelfar ignore Non constant level
upvar \#$opts(-level) $variable __vv
if { ! [info exists __vv]} {
set __vv $default
}
}
# TK helper to handle & in label
::tk::AmpMenuArgs $m add $type {*}$newOptions
if {$cfgvar ne ""} {
set ix [$m index end]
set tmp [list $m entryconfigure $ix]
uplevel \#$opts(-level) [list set $cfgvar $tmp]
}
if {$doBind ne ""} {
if {[regexp {^(.*)-(.*)$} $doBind -> pre post]} {
if {$pre eq "Ctrl"} {
set pre "Control"
}
set doBind $pre-Key-$post
} else {
set doBind Key-$doBind
}
#puts "Binding '$doBind' '$command'"
bind $opts(-top) <$doBind> $command
}
}
return $m
}
# Extract one entry from definiton
proc psmenu::PopEntry {defName} {
upvar 1 $defName def
set result {}
if {[lindex $def 0] eq "if"} {
# TBD support elseif
if {[lindex $def 0] eq "else"} {
set result [lrange $def 0 4]
set def [lrange $def 5 end]
} else {
set result [lrange $def 0 2]
set def [lrange $def 3 end]
}
return $result
}
set state "label"
set n -1
foreach arg $def {
incr n
switch $state {
"label" {
lappend result $arg
set state "option"
}
"option" {
if {[string match "--*" $arg]} {
incr n -1
break
} elseif {[string match "-*" $arg]} {
lappend result $arg
set state "value"
} elseif {[regexp {^\s+.*\s+$} $arg] || $arg eq ""} {
# recognise body somehow
lappend result $arg
break
} else {
# Must be next label
incr n -1
break
}
}
"value" {
lappend result $arg
set state "option"
}
}
}
incr n
set def [lrange $def $n end]
return $result
}
if 0 {
set mooo "Not set"
console show
package require Tk
update
wm geometry . 400x400
update
eval ${psmenu::example}
puts "mooo $mooo"
puts "mooa $mooa"
}