The XOWidget class
# here for the world
package provide xowidget 0.1
catch {
package require XOTcl
# this is necessary
namespace import ::xotcl::my
namespace import ::xotcl::self
package require Tk
}
namespace eval xowidget {
# check if we got Tcl 8.5 to use {*}syntax
variable _expand
if {[package vsatisfies [package require Tcl] 8.5]} {
set _expand yes
} else {
set _expand no
}
namespace export XOWidget
::xotcl::Class create _XOWidget -superclass ::xotcl::Class
_XOWidget instproc init {} {
# default values
my set __widget(hulltype) frame
my set __widget(adaptor) no
my set __options(list) ""
my set __options(*,delegated) no
if {$::xowidget::_expand} {
my instproc configurelist {{arg ""}} [expand {
my configure %EXP%$arg
}]
} else {
my instproc configurelist {{arg ""}} {
foreach {opt val} $arg {
my configure $opt $val
}
}
}
my instproc cget {opt} {
array set options [[self class] array get __options]
if {[lsearch -exact $options(list) $opt]<0} {
return [[my set $options(*,target)] cget $opt]
}
if {[info exists options($opt,cgetcmd)]} {
# this is a little machinery to avoid endless
# loops (recursivity when calling configure/cget in
# these handlers)
[self class] unset __options($opt,cgetcmd)
set value [my $options($opt,cgetcmd) $opt]
[self class] set __options($opt,cgetcmd) \
$options($opt,cgetcmd)
return $value
}
return [my set [::xowidget::xopt $opt]]
}
my instproc rawcget {opt} {
return [my set [::xowidget::xopt $opt]]
}
my instproc rawconfigure {opt value} {
my set [::xowidget::xopt $opt] $value
}
my instproc configure {args} {
if {[llength $args] == 0} {
return [my __show_configuration]
}
array set options [[self class] array get __options]
foreach {opt val} $args {
if {[lsearch -exact $options(list) $opt]<0} {
# unknown option, first look at option * delegation
if {$options(*,delegated)} {
[my set $options(*,target)] configure $opt $val
} else {
error "unknown option $opt"
}
} elseif {$options($opt,delegated)} {
# delegated option
[my set $options($opt,target)] configure $options($opt,delname) $val
} else {
# non-delegated option
if {[info exists options($opt,validatecmd)]} {
# throws an error when the value is invalid
my $options($opt,validatecmd) $val
}
if {[info exists options($opt,configurecmd)]} {
# this is a little machinery to avoid endless
# loops (recursivity when calling configure/cget in
# these handlers)
[self class] unset __options($opt,configurecmd)
my $options($opt,configurecmd) $opt $val
[self class] set __options($opt,configurecmd) \
$options($opt,configurecmd)
} else {
my set [::xowidget::xopt $opt] $val
}
}
}
return
}
my instproc __show_configuration {} {
set result ""
foreach opt [[self class] set __options(list)] {
set f $opt
if {[my exists [::xowidget::xopt $opt]]} {
lappend f [my set [::xowidget::xopt $opt]]
} else {
lappend f ""
}
lappend result $f
}
return $result
}
#
# installhull : the first command to call when you instanciate it
# part of Widget-specific methods
#
my instproc installhull {} {
# init options
set class [self class]
foreach opt [$class set __options(list)] {
if {![$class set __options($opt,delegated)] && [$class set __options($opt,default)]} {
my set [::xowidget::xopt $opt] [$class set __options($opt,value)]
}
}
# creates the hull
set path [::xowidget::pathFromSelf [self]]
if {![$class set __widget(adaptor)] ||
[$class set __widget(hulltype)] ne "existing"} {
uplevel 1 [linsert [$class set __widget(hulltype)] 1 $path]
}
# wraps the original widget
set i 0
while 1 {
incr i
set newname ::WidgetCmd$i$path
if {![llength [info commands $newname]]} break
}
rename ::$path $newname
proc ::$path {args} [string map [list %PATH% [self]] {
return [eval [linsert $args 0 %PATH%]]
}]
bind $path <Destroy> [list $path destroy]\n[list rename $path ""]
if {[$class set __widget(adaptor)]} {
my set hull $newname
} else {
my set hull $path
}
}
my instproc init {} {
my installhull
}
}
_XOWidget instproc option {name args} {
set opt [::xowidget::xopt $name]
my lappend __options(list) $name
my set __options($name,delegated) no
if {[llength $args]==0} {
# no default
my set __options($name,default) no
} elseif {[llength $args]==1} {
my set __options($name,default) yes
my set __options($name,value) [lindex $args 0]
return
}
foreach {key value} $args {
switch -- $key {
-default {
my set __options($name,default) yes
my set __options($name,value) $value
}
-configurecmd {
my set __options($name,configurecmd) $value
}
-cgetcmd {
my set __options($name,cgetcmd) $value
}
-validatecmd {
my set __options($name,validatecmd) $value
}
default {
error "unknown option option $key"
}
}
}
return
}
_XOWidget instproc hulltype {widget} {
if {[my set __widget(hulltype)]!="frame"} {
error "hulltype statement called twice"
}
my set __widget(hulltype) $widget
}
_XOWidget instproc setadaptor {args} {
my set __widget(adaptor) yes
my set __widget(hulltype) $args
my delegate option * to hull
my delegate instproc * to hull
}
#
# DELEGATION
#
_XOWidget instproc delegate {type args} {
eval [linsert $args 0 my __delegate_$type]
}
_XOWidget instproc __delegate_instproc {name args} {
set revamped $name
foreach {key value} $args {
switch -- $key {
as {set revamped $value}
to {set target $value}
default {error "unknown delegate statement"}
}
}
if {$name=="*"} {
if {$::xowidget::_expand} {
set body "\[my set $target\] \{*\}\$args"
} else {
set body "eval \[linsert \$args 0 \[my set $target\]\]"
}
my instproc unknown {args} $body
} else {
if {$::xowidget::_expand} {
set body "\[my set $target\] $revamped \{*\}\$args"
} else {
set body "eval \[linsert \$args 0 \[my set $target\] $revamped\]"
}
my instproc $name {args} $body
}
return
}
_XOWidget instproc __delegate_option {name args} {
if {[lsearch -exact [my set __options(list)] $name]>=0 &&
$name ne "*"} {
error "local option cannot be delegated"
}
if {$name ne "*"} {my lappend __options(list) $name}
my set __options($name,delegated) yes
my set __options($name,delname) $name
foreach {key value} $args {
switch -- $key {
as {
my set __options($name,delname) $value
}
to {
set hastarget yes ; # a marker
my set __options($name,target) $value
}
default {error "unknown delegate statement"}
}
}
if {![info exists hastarget]} {
error "delegate ... to target\ndelegation target missing"
}
return
}
#
# Entry point
#
proc XOWidget {class args} {
set wclass [transpose $class]
uplevel 1 ::xowidget::_XOWidget $wclass $args
# destroys the existing alias
catch {uplevel 1 [list interp alias {} $class {}]}
uplevel 1 [list interp alias {} $class {} ::xowidget::wset $class]
return $class
}
#
# Widget part (also in installhull method)
#
proc wset {class path args} {
set wclass [transpose $class]
if {[string index $path 0] ne "."} {
return [uplevel 1 [linsert $args 0 $wclass $path]]
}
set i 0
while {[llength [info commands ::Widget$i$path]]} {
incr i
}
set body [$wclass info instbody init]
if {![regexp {my installhull} $body]} {
uplevel 1 [list $wclass instproc init {} "my installhull\n$body"]
}
uplevel 1 $wclass create Widget$i$path
# parse arguments as any widget should: ?option value ?option value...??
if {[llength $args]} {uplevel 1 [list Widget$i$path configurelist $args]}
return $path
}
proc xopt {name} {
if {[string index $name 0] ne "-"} {
error "does not look like an option: $name"
}
return _[string range $name 1 end]
}
# introduce the expand syntax without making pre-8.5 Tcl
# arguing for this syntax
# to use like: [expand {configure %EXP%$args}]
# returns in this case : {configure {*}$args}
proc expand {body} {
string map {%EXP% \{*\}} $body
}
# given an instance identifier (obfuscated), finds the widget's path
proc pathFromSelf {self} {
return [string range $self [string first . $self] end]
}
#
# procs to transpose a (visible) type name into a (hidden) XOTcl class name
#
proc untranspose {name} {
return [string range $name 0 end-[string length __Widget]]
}
# gives the visible type name of an instance
proc transpose {name} {
return ${name}__Widget
}
}An example:
# widget example to be launched by wish
package require Tk
lappend auto_path .
package require xowidget
xowidget::XOWidget Button
# options
Button option -fontfamily -default "" -configurecmd fontfamily
Button setadaptor existing
Button instproc init {} {
my instvar hull
$hull configure -text "Click me"
}
Button instproc fontfamily {opt value} {
my instvar hull
set font [$hull cget -font]
lset font 0 $value
$hull configure -font $font
my rawconfigure $opt $value
}
proc try {firstname name} {
global btn
tk_messageBox -message "Have you ever tried to look like $firstname $name?"
destroy $btn
button $btn
Button $btn -text "Exit" -command exit
pack $btn
update
}
# 'Button' arguments are treated after creation
# by calling automatically the configure method
button .btn
set btn [Button .btn -fontfamily times -text "Top Cool Language" -command {try Freddie Mercury}]
# comment this when you've got a toplevel hulltype, of course
pack .btn
update
tk_messageBox -message "option list : [$btn configure]"The example is adapted from Xoins, a Snit emulation in XOTcl.Widget adaptor example
# widget example to be launched by wish
package require Tk
lappend auto_path .
package require xowidget
xowidget::XOWidget Button
# options
Button option -packpad -default 10 -configurecmd packpad
Button option -fontfamily -default "" -configurecmd fontfamily
Button delegate option * to button
Button delegate option -text to button
Button instproc init {} {
my instvar hull
my set button [button $hull.b -text "Click me"]
pack [my set button] -padx 10 -pady 10 -in $hull
}
Button instproc destroy {} {
catch {destroy [my set button]}
}
Button instproc packpad {opt value} {
pack configure [my set button] -padx $value -pady $value
my rawconfigure $opt $value
}
Button instproc fontfamily {opt value} {
my instvar button
set font [$button cget -font]
lset font 0 $value
$button configure -font $font
my rawconfigure $opt $value
}
proc try {firstname name} {
global btn
tk_messageBox -message "Have you ever tried to look like $firstname $name?"
destroy $btn
Button $btn -text "Exit" -command exit -packpad 5
pack $btn
}
# 'Button' arguments are treated after creation
# by calling automatically the configure method
set btn [Button .btn -fontfamily times -text "Top Cool Language" -command {try Paul McCartney;update}]
# comment this when you've got a toplevel hulltype, of course
pack .btn
update
.btn configure -packpad 15
tk_messageBox -message "option list : [$btn configure]"