#---------------------------------------------------------*-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.0
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
# -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
}
}
}
# Main call for psmenu. Optional arguments are for internal use.
proc psmenu::psmenu {top def {Toplevel ""} {Level ""}} {
if {$top eq "."} {
set m .m
} else {
set m $top.m
}
if {$Toplevel ne ""} {
# 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 exists for a second user call
if { ! [winfo exists $m]} {
# Create
menu $m -tearoff 0
}
if {$Level eq ""} {
# Store initial level to handle scope when recursing cascades
set Level [uplevel 1 info level]
}
if {$Toplevel eq ""} {
set Toplevel $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
}
# 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 \#$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 $body $Toplevel $Level]
# 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 default 0
foreach {opt val} $options {
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
}
}
-cmd - -command {
set val [uplevel \#$Level [list subst $val]]
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 \#$Level [list set $variable $val]
}
}
-def {
set default $val
}
default {
# Just let through
lappend newOptions $opt $val
}
}
}
if {$variable ne ""} {
upvar \#$Level $variable __vv
if {![info exists __vv]} {
set __vv $default
}
}
# TK helper to handle & in label
::tk::AmpMenuArgs $m add $type {*}$newOptions
if {$doBind ne ""} {
if {[regexp {^(.*)-(.*)$} $doBind -> pre post]} {
set doBind $pre-Key-$post
} else {
set doBind Key-$doBind
}
#puts "Binding '$doBind' '$command'"
bind $Toplevel <$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"
}