976 lines
32 KiB
Tcl
976 lines
32 KiB
Tcl
## Barebones requirements for creating and querying megawidgets
|
|
##
|
|
## Copyright 1997-8 Jeffrey Hobbs, jeff.hobbs@acm.org
|
|
##
|
|
## Initiated: 5 June 1997
|
|
## Last Update: 1998
|
|
|
|
package require Tk 8
|
|
package require ::Utility
|
|
package provide Widget 2.0
|
|
|
|
##------------------------------------------------------------------------
|
|
## PROCEDURE
|
|
## widget
|
|
##
|
|
## DESCRIPTION
|
|
## Implements and modifies megawidgets
|
|
##
|
|
## ARGUMENTS
|
|
## widget <subcommand> ?<args>?
|
|
##
|
|
## <classname> specifies a global array which is the name of a class and
|
|
## contains options database information.
|
|
##
|
|
## add classname option ?args?
|
|
## adds ...
|
|
##
|
|
## create classname
|
|
## creates the widget class $classname based on the specifications
|
|
## in the global array of the same name
|
|
##
|
|
## classes ?pattern?
|
|
## returns the classes created with this command.
|
|
##
|
|
## delete classname option ?args?
|
|
## deletes ...
|
|
##
|
|
## value classname key
|
|
## returns the value of a key from the special class variable.
|
|
##
|
|
## OPTIONS
|
|
## none
|
|
##
|
|
## RETURNS
|
|
## the namespace for the widget class (::Widget::$CLASS)
|
|
##
|
|
## NAMESPACE & STATE
|
|
## The namespace Widget is used, with public procedure "widget".
|
|
##
|
|
##------------------------------------------------------------------------
|
|
##
|
|
## For a well-commented example for creating a megawidget using this method,
|
|
## see the ScrolledText example at the end of the file.
|
|
##
|
|
## SHORT LIST OF IMPORTANT THINGS TO KNOW:
|
|
##
|
|
## Specify the "type", "base", & "components" keys of the $CLASS global array
|
|
##
|
|
## In the $w global array that is created for each instance of a megawidget,
|
|
## the following keys are set by the "widget create $CLASS" procedure:
|
|
## "base", "basecmd", "container", "class", any option specified in the
|
|
## $CLASS array, each component will have a named key
|
|
##
|
|
## The following public methods are created for you in the namespace:
|
|
## cget ::Widget::$CLASS::_cget
|
|
## configure ::Widget::$CLASS::_configure
|
|
## destruct ::Widget::$CLASS::_destruct
|
|
## subwidget ::Widget::$CLASS::_subwidget
|
|
## The following additional submethods are required (you write them):
|
|
## construct ::Widget::$CLASS::construct
|
|
## configure ::Widget::$CLASS::configure
|
|
## You may want the following that will be called when appropriate:
|
|
## init ::Widget::$CLASS::init
|
|
## (after initial configuration)
|
|
## destruct ::Widget::$CLASS::destruct
|
|
## (called first thing when widget is being destroyed)
|
|
##
|
|
## All ::Widget::$CLASS::_* commands are considered public methods. The
|
|
## megawidget routine will match your options and methods on a unique
|
|
## substring basis.
|
|
##
|
|
## END OF SHORT LIST
|
|
|
|
|
|
## Dummy call for indexers
|
|
proc widget args {}
|
|
|
|
namespace eval ::Widget {;
|
|
|
|
namespace export -clear widget
|
|
variable CLASSES
|
|
variable CONTAINERS {frame toplevel}
|
|
namespace import -force ::Utility::get_opts*
|
|
|
|
;proc widget {cmd args} {
|
|
## Establish the prefix of public commands
|
|
set prefix [namespace current]::_
|
|
if {[string match {} [set arg [info commands $prefix$cmd]]]} {
|
|
set arg [info commands $prefix$cmd*]
|
|
}
|
|
switch [llength $arg] {
|
|
1 { return [uplevel $arg $args] }
|
|
0 {
|
|
set arg [info commands $prefix*]
|
|
regsub -all $prefix $arg {} arg
|
|
return -code error "unknown [lindex [info level 0] 0] method\
|
|
\"$cmd\", must be one of: [join [lsort $arg] {, }]"
|
|
}
|
|
default {
|
|
regsub -all $prefix $arg {} arg
|
|
return -code error "ambiguous method \"$cmd\",\
|
|
could be one of: [join [lsort $arg] {, }]"
|
|
}
|
|
}
|
|
}
|
|
|
|
;proc verify_class {CLASS} {
|
|
variable CLASSES
|
|
if {![info exists CLASSES($CLASS)]} {
|
|
return -code error "no known class \"$CLASS\""
|
|
}
|
|
return
|
|
}
|
|
|
|
;proc _add {CLASS what args} {
|
|
variable CLASSES
|
|
verify_class $CLASS
|
|
if {[string match ${what}* options]} {
|
|
add_options $CLASSES($CLASS) $CLASS $args
|
|
} else {
|
|
return -code error "unknown type for add, must be one of:\
|
|
options, components"
|
|
}
|
|
}
|
|
|
|
;proc _find_class {CLASS {root .}} {
|
|
if {[string match $CLASS [winfo class $root]]} {
|
|
return $root
|
|
} else {
|
|
foreach w [winfo children $root] {
|
|
set w [_find_class $CLASS $w]
|
|
if {[string compare {} $w]} {
|
|
return $w
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
;proc _delete {CLASS what args} {
|
|
variable CLASSES
|
|
verify_class $CLASS
|
|
}
|
|
|
|
;proc _classes {{pattern "*"}} {
|
|
variable CLASSES
|
|
return [array names CLASSES $pattern]
|
|
}
|
|
|
|
;proc _value {CLASS key} {
|
|
variable CLASSES
|
|
verify_class $CLASS
|
|
upvar \#0 $CLASSES($CLASS)::class class
|
|
if {[info exists class($key)]} {
|
|
return $class($key)
|
|
} else {
|
|
return -code error "unknown key \"$key\" in class \"$CLASS\""
|
|
}
|
|
}
|
|
|
|
## handle
|
|
## Handles the method calls for a widget. This is the command to which
|
|
## all megawidget dummy commands are redirected for interpretation.
|
|
##
|
|
;proc handle {namesp w subcmd args} {
|
|
upvar \#0 ${namesp}::$w data
|
|
if {[string match {} [set arg [info commands ${namesp}::_$subcmd]]]} {
|
|
set arg [info commands ${namesp}::_$subcmd*]
|
|
}
|
|
set num [llength $arg]
|
|
if {$num==1} {
|
|
return [uplevel $arg [list $w] $args]
|
|
} elseif {$num} {
|
|
regsub -all "${namesp}::_" $arg {} arg
|
|
return -code error "ambiguous method \"$subcmd\",\
|
|
could be one of: [join $arg {, }]"
|
|
} elseif {[catch {uplevel [list $data(basecmd) $subcmd] $args} err]} {
|
|
return -code error $err
|
|
} else {
|
|
return $err
|
|
}
|
|
}
|
|
|
|
## construct
|
|
## Constructs the megawidget instance instantiation proc based on the
|
|
## current knowledge of the megawidget.
|
|
##
|
|
;proc construct {namesp CLASS} {
|
|
upvar \#0 ${namesp}::class class \
|
|
${namesp}::components components
|
|
|
|
lappend dataArrayVals [list class $CLASS]
|
|
if {[string compare $class(type) $class(base)]} {
|
|
## If -type and -base don't match, we need a special setup
|
|
lappend dataArrayVals "base \$w.[list [lindex $components(base) 1]]" \
|
|
"basecmd ${namesp}::\$w.[list [lindex $components(base) 1]]" \
|
|
"container ${namesp}::.\$w"
|
|
## If the base widget is not the container, then we want to rename
|
|
## its widget commands and add the CLASS and container bind tables
|
|
## to its bindtags in case certain bindings are made
|
|
## Interp alias is the optimal solution, but exposes
|
|
## a bug in Tcl7/8 when renaming aliases
|
|
#interp alias {} \$base {} ::Widget::handle $namesp \$w
|
|
set renamingCmd "rename \$base \$data(basecmd)
|
|
;proc ::\$base args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\"
|
|
bindtags \$base \[linsert \[bindtags \$base\] 1\
|
|
[expr {[string match toplevel $class(type)]?{}:{$w}}] $CLASS\]"
|
|
} else {
|
|
## -type and -base are the same, we only create for one
|
|
lappend dataArrayVals "base \$w" \
|
|
"basecmd ${namesp}::\$w" \
|
|
"container ${namesp}::\$w"
|
|
if {[string compare {} [lindex $components(base) 3]]} {
|
|
lappend dataArrayVals "[lindex $components(base) 3] \$w"
|
|
}
|
|
## When the base widget and container are the same, we have a
|
|
## straightforward renaming of commands
|
|
set renamingCmd {}
|
|
}
|
|
set baseConstruction {}
|
|
foreach name [array names components] {
|
|
if {[string match base $name]} {
|
|
continue
|
|
}
|
|
foreach {type wid opts} $components($name) break
|
|
lappend dataArrayVals "[list $name] \$w.[list $wid]"
|
|
lappend baseConstruction "$type \$w.[list $wid] $opts"
|
|
if {[string match toplevel $type]} {
|
|
lappend baseConstruction "wm withdraw \$data($name)"
|
|
}
|
|
}
|
|
set dataArrayVals [join $dataArrayVals " \\\n\t"]
|
|
## the lsort ensure that parents are created before children
|
|
set baseConstruction [join [lsort -index 1 $baseConstruction] "\n "]
|
|
|
|
## More of this proc could be configured ahead of time for increased
|
|
## construction speed. It's delicate, so handle with extreme care.
|
|
;proc ${namesp}::$CLASS {w args} [subst {
|
|
variable options
|
|
upvar \#0 ${namesp}::\$w data
|
|
$class(type) \$w -class $CLASS
|
|
[expr [string match toplevel $class(type)]?{wm withdraw \$w\n}:{}]
|
|
## Populate data array with user definable options
|
|
foreach o \[array names options\] {
|
|
if {\[string match -* \$options(\$o)\]} continue
|
|
set data(\$o) \[option get \$w \[lindex \$options(\$o) 0\] $CLASS\]
|
|
}
|
|
|
|
## Populate the data array
|
|
array set data \[list $dataArrayVals\]
|
|
## Create all the base and component widgets
|
|
$baseConstruction
|
|
|
|
## Allow for an initialization proc to be eval'ed
|
|
## The user must create one
|
|
if {\[catch {construct \$w} err\]} {
|
|
catch {_destruct \$w}
|
|
return -code error \"megawidget construction error: \$err\"
|
|
}
|
|
|
|
set base \$data(base)
|
|
rename \$w \$data(container)
|
|
$renamingCmd
|
|
;proc ::\$w args \"uplevel ::Widget::handle $namesp \[list \$w\] \\\$args\"
|
|
#interp alias {} \$w {} ::Widget::handle $namesp \$w
|
|
|
|
## Do the configuring here and eval the post initialization procedure
|
|
if {(\[string compare {} \$args\] && \
|
|
\[catch {uplevel 1 ${namesp}::_configure \$w \$args} err\]) || \
|
|
\[catch {${namesp}::init \$w} err\]} {
|
|
catch { ${namesp}::_destruct \$w }
|
|
return -code error \"megawidget initialization error: \$err\"
|
|
}
|
|
|
|
return \$w
|
|
}
|
|
]
|
|
}
|
|
|
|
;proc add_options {namesp CLASS optlist} {
|
|
upvar \#0 ${namesp}::class class \
|
|
${namesp}::options options \
|
|
${namesp}::widgets widgets
|
|
## Go through the option definition, substituting for ALIAS where
|
|
## necessary and setting up the options database for this $CLASS
|
|
## There are several possible formats:
|
|
## 1. -optname -optnamealias
|
|
## 2. -optname dbname dbcname value
|
|
## 3. -optname ALIAS componenttype option
|
|
## 4. -optname ALIAS componenttype option dbname dbcname
|
|
foreach optdef $optlist {
|
|
foreach {optname alias type opt dbname dbcname} $optdef break
|
|
set len [llength $optdef]
|
|
switch -glob -- $alias {
|
|
-* {
|
|
if {$len != 2} {
|
|
return -code error "wrong \# args for option alias,\
|
|
must be: {-aliasoptioname -realoptionname}"
|
|
}
|
|
set options($optname) $alias
|
|
continue
|
|
}
|
|
ALIAS - alias {
|
|
if {$len != 4 && $len != 6} {
|
|
return -code error "wrong \# args for ALIAS, must be:\
|
|
{-optionname ALIAS componenttype option\
|
|
?databasename databaseclass?}"
|
|
}
|
|
if {![info exists widgets($type)]} {
|
|
return -code error "cannot create alias \"$optname\" to\
|
|
$CLASS component type \"$type\" option \"$opt\":\
|
|
component type does not exist"
|
|
} elseif {![info exists config($type)]} {
|
|
if {[string compare toplevel $type]} {
|
|
set w .__widget__$type
|
|
catch {destroy $w}
|
|
## Make sure the component widget type exists,
|
|
## returns the widget name,
|
|
## and accepts configure as a subcommand
|
|
if {[catch {$type $w} result] || \
|
|
[string compare $result $w] || \
|
|
[catch {$w configure} config($type)]} {
|
|
## Make sure we destroy it if it was a bad widget
|
|
catch {destroy $w}
|
|
## Or rename it if it was a non-widget command
|
|
catch {rename $w {}}
|
|
return -code error "invalid widget type \"$type\""
|
|
}
|
|
catch {destroy $w}
|
|
} else {
|
|
set config($type) [. configure]
|
|
}
|
|
}
|
|
set i [lsearch -glob $config($type) "$opt\[ \t\]*"]
|
|
if {$i == -1} {
|
|
return -code error "cannot create alias \"$o\" to $CLASS\
|
|
component type \"$type\" option \"$opt\":\
|
|
option does not exist"
|
|
}
|
|
if {$len==4} {
|
|
foreach {opt dbname dbcname def} \
|
|
[lindex $config($type) $i] break
|
|
} elseif {$len==6} {
|
|
set def [lindex [lindex $config($type) $i] 3]
|
|
}
|
|
}
|
|
default {
|
|
if {$len != 4} {
|
|
return -code error "wrong \# args for option \"$optdef\",\
|
|
must be:\
|
|
{-optioname databasename databaseclass defaultval}"
|
|
}
|
|
foreach {optname dbname dbcname def} $optdef break
|
|
}
|
|
}
|
|
set options($optname) [list $dbname $dbcname $def]
|
|
option add *$CLASS.$dbname $def widgetDefault
|
|
}
|
|
}
|
|
|
|
;proc _create {CLASS args} {
|
|
if {![string match {[A-Z]*} $CLASS] || [string match { } $CLASS]} {
|
|
return -code error "invalid class name \"$CLASS\": it must begin\
|
|
with a capital letter and contain no spaces"
|
|
}
|
|
|
|
variable CONTAINERS
|
|
variable CLASSES
|
|
set namesp [namespace current]::$CLASS
|
|
namespace eval $namesp {
|
|
variable class
|
|
variable options
|
|
variable components
|
|
variable widgets
|
|
catch {unset class}
|
|
catch {unset options}
|
|
catch {unset components}
|
|
catch {unset widgets}
|
|
}
|
|
upvar \#0 ${namesp}::class class \
|
|
${namesp}::options options \
|
|
${namesp}::components components \
|
|
${namesp}::widgets widgets
|
|
|
|
get_opts2 classopts $args {
|
|
-type frame
|
|
-base frame
|
|
-components {}
|
|
-options {}
|
|
} {
|
|
-type list
|
|
-base list
|
|
-components list
|
|
-options list
|
|
}
|
|
|
|
## First check to see that their container type is valid
|
|
## I'd like to include canvas and text, but they don't accept the
|
|
## -class option yet, which would thus require some voodoo on the
|
|
## part of the constructor to make it think it was the proper class
|
|
if {![regexp ^([join $CONTAINERS |])\$ $classopts(-type)]} {
|
|
return -code error "invalid class container type\
|
|
\"$classopts(-type)\", must be one of:\
|
|
[join $CONTAINERS {, }]"
|
|
}
|
|
|
|
## Then check to see that their base widget type is valid
|
|
## We will create a default widget of the appropriate type just in
|
|
## case they use the DEFAULT keyword as a default value in their
|
|
## megawidget class definition
|
|
if {[info exists classopts(-base)]} {
|
|
## We check to see that we can create the base, that it returns
|
|
## the same widget value we put in, and that it accepts cget.
|
|
if {[string match toplevel $classopts(-base)] && \
|
|
[string compare toplevel $classopts(-type)]} {
|
|
return -code error "\"toplevel\" is not allowed as the base\
|
|
widget of a megawidget (perhaps you intended it to\
|
|
be the class type)"
|
|
}
|
|
} else {
|
|
## The container is the default base widget
|
|
set classopts(-base) $classopts(-type)
|
|
}
|
|
|
|
## Ensure that the class is set correctly
|
|
array set class [list class $CLASS \
|
|
base $classopts(-base) \
|
|
type $classopts(-type)]
|
|
|
|
set widgets($class(type)) 0
|
|
|
|
if {![info exists classopts(-components)]} {
|
|
set classopts(-components) {}
|
|
}
|
|
foreach compdef $classopts(-components) {
|
|
set opts {}
|
|
switch [llength $compdef] {
|
|
0 continue
|
|
1 { set name [set type [set wid $compdef]] }
|
|
2 {
|
|
set type [lindex $compdef 0]
|
|
set name [set wid [lindex $compdef 1]]
|
|
}
|
|
default {
|
|
foreach {type name wid opts} $compdef break
|
|
set opts [string trim $opts]
|
|
}
|
|
}
|
|
if {[info exists components($name)]} {
|
|
return -code error "component name \"$name\" occurs twice\
|
|
in $CLASS class"
|
|
}
|
|
if {[info exists widnames($wid)]} {
|
|
return -code error "widget name \"$wid\" occurs twice\
|
|
in $CLASS class"
|
|
}
|
|
if {[regexp {(^[\.A-Z]| |\.$)} $wid]} {
|
|
return -code error "invalid $CLASS class component widget\
|
|
name \"$wid\": it cannot begin with a capital letter,\
|
|
contain spaces or start or end with a \".\""
|
|
}
|
|
if {[string match *.* $wid] && \
|
|
![info exists widnames([file root $wid])]} {
|
|
## If the widget name contains a '.', then make sure we will
|
|
## have created all the parents first. [file root $wid] is
|
|
## a cheap trick to remove the last .child string from $wid
|
|
return -code error "no specified parent for $CLASS class\
|
|
component widget name \"$wid\""
|
|
}
|
|
if {[string match base $type]} {
|
|
set type $class(base)
|
|
set components(base) [list $type $wid $opts $name]
|
|
if {[string match $type $class(type)]} continue
|
|
}
|
|
set components($name) [list $type $wid $opts]
|
|
set widnames($wid) 0
|
|
set widgets($type) 0
|
|
}
|
|
if {![info exists components(base)]} {
|
|
set components(base) [list $class(base) $class(base) {}]
|
|
# What should we really do here?
|
|
#set components($class(base)) $components(base)
|
|
set widgets($class(base)) 0
|
|
if {![regexp ^([join $CONTAINERS |])\$ $class(base)] && \
|
|
![info exists components($class(base))]} {
|
|
set components($class(base)) $components(base)
|
|
}
|
|
}
|
|
|
|
## Process options
|
|
add_options $namesp $CLASS $classopts(-options)
|
|
|
|
namespace eval $namesp {
|
|
set CLASS [namespace tail [namespace current]]
|
|
## The _destruct must occur to remove excess state elements.
|
|
## The [winfo class %W] will work in this Destroy, which is necessary
|
|
## to determine if we are destroying the actual megawidget container.
|
|
bind $CLASS <Destroy> [namespace code {
|
|
if {[string compare {} [::widget classes [::winfo class %W]]]} {
|
|
if [catch {_destruct %W} err] { puts $err }
|
|
}
|
|
}]
|
|
}
|
|
## This creates the basic constructor procedure for the class
|
|
## as ${namesp}::$CLASS
|
|
construct $namesp $CLASS
|
|
|
|
## Both $CLASS and [string tolower $CLASS] commands will be created
|
|
## in the global namespace
|
|
namespace eval $namesp [list namespace export -clear $CLASS]
|
|
namespace eval :: [list namespace import -force ${namesp}::$CLASS]
|
|
interp alias {} ::[string tolower $CLASS] {} ::$CLASS
|
|
|
|
## These are provided so that errors due to lack of the command
|
|
## existing don't arise. Since they are stubbed out here, the
|
|
## user can't depend on 'unknown' or 'auto_load' to get this proc.
|
|
if {[string match {} [info commands ${namesp}::construct]]} {
|
|
;proc ${namesp}::construct {w} {
|
|
# the user should rewrite this
|
|
# without the following error, a simple megawidget that was just
|
|
# a frame would be created by default
|
|
return -code error "user must write their own\
|
|
[lindex [info level 0] 0] function"
|
|
}
|
|
}
|
|
if {[string match {} [info commands ${namesp}::init]]} {
|
|
;proc ${namesp}::init {w} {
|
|
# the user should rewrite this
|
|
}
|
|
}
|
|
|
|
## The user is not supposed to change this proc
|
|
set comps [lsort [array names components]]
|
|
;proc ${namesp}::_subwidget {w {widget return} args} [subst {
|
|
variable \$w
|
|
upvar 0 \$w data
|
|
switch -- \$widget {
|
|
return {
|
|
return [list $comps]
|
|
}
|
|
all {
|
|
if {\[string compare {} \$args\]} {
|
|
foreach sub [list $comps] {
|
|
catch {uplevel 1 \[list \$data(\$sub)\] \$args}
|
|
}
|
|
} else {
|
|
return [list $comps]
|
|
}
|
|
}
|
|
[join $comps { - }] {
|
|
if {\[string compare {} \$args\]} {
|
|
return \[uplevel 1 \[list \$data(\$widget)\] \$args\]
|
|
} else {
|
|
return \$data(\$widget)
|
|
}
|
|
}
|
|
default {
|
|
return -code error \"No \$data(class) subwidget \\\"\$widget\\\",\
|
|
must be one of: [join $comps {, }]\"
|
|
}
|
|
}
|
|
}]
|
|
|
|
## The user is not supposed to change this proc
|
|
## Instead they create a ::Widget::$CLASS::destruct proc
|
|
## Some of this may be redundant, but at least it does the job
|
|
;proc ${namesp}::_destruct {w} "
|
|
upvar \#0 ${namesp}::\$w data
|
|
catch {${namesp}::destruct \$w}
|
|
catch {::destroy \$data(base)}
|
|
catch {::destroy \$w}
|
|
catch {rename \$data(basecmd) {}}
|
|
catch {rename ::\$data(base) {}}
|
|
catch {rename ::\$w {}}
|
|
catch {unset data}
|
|
return\n"
|
|
|
|
if {[string match {} [info commands ${namesp}::destruct]]} {
|
|
## The user can optionally provide a special destroy handler
|
|
;proc ${namesp}::destruct {w args} {
|
|
# empty
|
|
}
|
|
}
|
|
|
|
## The user is not supposed to change this proc
|
|
;proc ${namesp}::_cget {w args} {
|
|
if {[llength $args] != 1} {
|
|
return -code error "wrong \# args: should be \"$w cget option\""
|
|
}
|
|
set namesp [namespace current]
|
|
upvar \#0 ${namesp}::$w data ${namesp}::options options
|
|
if {[info exists options($args)]&&[string match -* $options($args)]} {
|
|
set args $options($args)
|
|
}
|
|
if {[string match {} [set arg [array names data $args]]]} {
|
|
set arg [array names data ${args}*]
|
|
}
|
|
set num [llength $arg]
|
|
if {$num==1} {
|
|
return $data($arg)
|
|
} elseif {$num} {
|
|
return -code error "ambiguous option \"$args\",\
|
|
must be one of: [join $arg {, }]"
|
|
} elseif {[catch {$data(basecmd) cget $args} err]} {
|
|
return -code error $err
|
|
} else {
|
|
return $err
|
|
}
|
|
}
|
|
|
|
## The user is not supposed to change this proc
|
|
## Instead they create a $CLASS:configure proc
|
|
;proc ${namesp}::_configure {w args} {
|
|
set namesp [namespace current]
|
|
upvar \#0 ${namesp}::$w data ${namesp}::options options
|
|
|
|
set num [llength $args]
|
|
if {$num==1} {
|
|
if {[info exists options($args)] && \
|
|
[string match -* $options($args)]} {
|
|
set args $options($args)
|
|
}
|
|
if {[string match {} [set arg [array names data $args]]]} {
|
|
set arg [array names data ${args}*]
|
|
}
|
|
set num [llength $arg]
|
|
if {$num==1} {
|
|
## FIX one-elem config
|
|
return "[list $arg] $options($arg) [list $data($arg)]"
|
|
} elseif {$num} {
|
|
return -code error "ambiguous option \"$args\",\
|
|
must be one of: [join $arg {, }]"
|
|
} elseif {[catch {$data(basecmd) configure $args} err]} {
|
|
return -code error $err
|
|
} else {
|
|
return $err
|
|
}
|
|
} elseif {$num} {
|
|
## Group the {key val} pairs to be distributed
|
|
if {$num&1} {
|
|
set last [lindex $args end]
|
|
set args [lrange $args 0 [incr num -2]]
|
|
}
|
|
set widargs {}
|
|
set cmdargs {}
|
|
foreach {key val} $args {
|
|
if {[info exists options($key)] && \
|
|
[string match -* $options($key)]} {
|
|
set key $options($key)
|
|
}
|
|
if {[string match {} [set arg [array names data $key]]]} {
|
|
set arg [array names data $key*]
|
|
}
|
|
set len [llength $arg]
|
|
if {$len==1} {
|
|
lappend widargs $arg $val
|
|
} elseif {$len} {
|
|
set ambarg [list $key $arg]
|
|
break
|
|
} else {
|
|
lappend cmdargs $key $val
|
|
}
|
|
}
|
|
if {[string compare {} $widargs]} {
|
|
uplevel ${namesp}::configure [list $w] $widargs
|
|
}
|
|
if {[string compare {} $cmdargs] && [catch \
|
|
{uplevel [list $data(basecmd)] configure $cmdargs} err]} {
|
|
return -code error $err
|
|
}
|
|
if {[info exists ambarg]} {
|
|
return -code error "ambiguous option \"[lindex $ambarg 0]\",\
|
|
must be one of: [join [lindex $ambarg 1] {, }]"
|
|
}
|
|
if {[info exists last]} {
|
|
return -code error "value for \"$last\" missing"
|
|
}
|
|
} else {
|
|
foreach opt [$data(basecmd) configure] {
|
|
set opts([lindex $opt 0]) [lrange $opt 1 end]
|
|
}
|
|
foreach opt [array names options] {
|
|
if {[string match -* $options($opt)]} {
|
|
set opts($opt) [string range $options($opt) 1 end]
|
|
} else {
|
|
set opts($opt) "$options($opt) [list $data($opt)]"
|
|
}
|
|
}
|
|
foreach opt [lsort [array names opts]] {
|
|
lappend config "$opt $opts($opt)"
|
|
}
|
|
return $config
|
|
}
|
|
}
|
|
|
|
if {[string match {} [info commands ${namesp}::configure]]} {
|
|
## The user is intended to rewrite this one
|
|
;proc ${namesp}::configure {w args} {
|
|
foreach {key val} $args {
|
|
puts "$w: configure $key to [list $value]"
|
|
}
|
|
}
|
|
}
|
|
|
|
set CLASSES($CLASS) $namesp
|
|
return $namesp
|
|
}
|
|
|
|
}; #end namespace ::Widget
|
|
|
|
namespace eval :: { namespace import -force ::Widget::widget }
|
|
|
|
########################################################################
|
|
########################## EXAMPLES ####################################
|
|
########################################################################
|
|
|
|
########################################################################
|
|
########################## ScrolledText ################################
|
|
########################################################################
|
|
|
|
##------------------------------------------------------------------------
|
|
## PROCEDURE
|
|
## scrolledtext
|
|
##
|
|
## DESCRIPTION
|
|
## Implements a ScrolledText mega-widget
|
|
##
|
|
## ARGUMENTS
|
|
## scrolledtext <window pathname> <options>
|
|
##
|
|
## OPTIONS
|
|
## (Any text widget option may be used in addition to these)
|
|
##
|
|
## -autoscrollbar TCL_BOOLEAN DEFAULT: 1
|
|
## Whether to have dynamic or static scrollbars.
|
|
##
|
|
## RETURNS: the window pathname
|
|
##
|
|
## METHODS/SUBCOMMANDS
|
|
## These are the subcmds that an instance of this megawidget recognizes.
|
|
## Aside from those listed here, it accepts subcmds that are valid for
|
|
## text widgets.
|
|
##
|
|
## subwidget widget
|
|
## Returns the true widget path of the specified widget. Valid
|
|
## widgets are text, xscrollbar, yscrollbar.
|
|
##
|
|
## BINDINGS (in addition to default widget bindings)
|
|
##
|
|
## NAMESPACE & STATE
|
|
## The megawidget creates a global array with the classname, and a
|
|
## global array which is the name of each megawidget is created. The latter
|
|
## array is deleted when the megawidget is destroyed.
|
|
## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
|
|
## Other procs that begin with $CLASSNAME are private. For each widget,
|
|
## commands named .$widgetname and $CLASSNAME$widgetname are created.
|
|
##
|
|
## EXAMPLE USAGE:
|
|
##
|
|
## pack [scrolledtext .st -width 40 -height 10] -fill both -exp 1
|
|
##
|
|
##------------------------------------------------------------------------
|
|
|
|
## Each widget created will also have a global array created by the
|
|
## instantiation procedure that is the name of the widget (represented
|
|
## as $w below). There three special key names in the $CLASS array:
|
|
##
|
|
## -type
|
|
## the type of base container we want to use (frame or toplevel).
|
|
## This would default to frame. This widget will be created for us
|
|
## by the constructor function. The $w array will have a "container"
|
|
## key that will point to the exact widget name.
|
|
##
|
|
## -base
|
|
## the base widget type for this class. This key is optional and
|
|
## represents what kind of widget will be the base for the class. This
|
|
## way we know what default methods/options you'll have. If not
|
|
## specified, it defaults to the container type.
|
|
## To the global $w array, the key "basecmd" will be added by the widget
|
|
## instantiation function to point to a new proc that will be the direct
|
|
## accessor command for the base widget ("text" in the case of the
|
|
## ScrolledText megawidget). The $w "base" key will be the valid widget
|
|
## name (for passing to [winfo] and such), but "basecmd" will be the
|
|
## valid direct accessor function
|
|
##
|
|
## -components
|
|
## the component widgets of the megawidget. This is a list of tuples
|
|
## (ie: {{listbox listbox} {scrollbar yscrollbar} {scrollbar xscrollbar}})
|
|
## where each item is in the form {widgettype name}. These components
|
|
## will be created before the $CLASS::construct proc is called and the $w
|
|
## array will have keys with each name pointing to the appropriate
|
|
## widget in it. Use these keys to access your subwidgets. It is from
|
|
## this component list and the base and type about that the subwidget
|
|
## method is created.
|
|
##
|
|
## -options
|
|
## A list of lists, this specifies the
|
|
## options that this megawidget handles. The value can either be a
|
|
## 3-tuple list of the form {databaseName databaseClass defaultValue}, or
|
|
## it can be one element matching -*, which means this key (say -bd) is
|
|
## an alias for the option specified in the value (say -borderwidth)
|
|
## which must be specified fully somewhere else in the class array.
|
|
##
|
|
## If the value is a list beginning with "ALIAS", then the option is derived
|
|
## from a component of the megawidget. The form of the value must be a list
|
|
## with the elements:
|
|
## {ALIAS componenttype option ?databasename databaseclass?}
|
|
## An example of this would be inheriting a label components anchor:
|
|
## {ALIAS label -anchor labelAnchor Anchor}
|
|
## If the databasename is not specified, it determines the final options
|
|
## database info from the component and uses the components default value.
|
|
## Otherwise, just the components default value is used.
|
|
##
|
|
## The $w array will be populated by the instantiation procedure with the
|
|
## default values for all the specified $CLASS options.
|
|
##
|
|
|
|
# Create this to make sure there are registered in auto_mkindex
|
|
# these must come before the [widget create ...]
|
|
proc ScrolledText args {}
|
|
proc scrolledtext args {}
|
|
widget create ScrolledText -type frame -base text -components {
|
|
{base text text {-xscrollcommand [list $data(xscrollbar) set] \
|
|
-yscrollcommand [list $data(yscrollbar) set]}}
|
|
{scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1 \
|
|
-command [list $w xview]}}
|
|
{scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1 \
|
|
-command [list $w yview]}}
|
|
} -options {
|
|
{-autoscrollbar autoScrollbar AutoScrollbar 1}
|
|
}
|
|
|
|
## Then we "create" the widget. This makes all the necessary default widget
|
|
## routines. It creates the public accessor functions ($CLASSNAME and
|
|
## [string tolower $CLASSNAME]) as well as the public cget, configure, destroy
|
|
## and subwidget methods. The cget and configure commands work like the
|
|
## regular Tk ones. The destroy method is superfluous, as megawidgets will
|
|
## respond properly to [destroy $widget] (the Tk destroy command).
|
|
## The subwidget method has the following form:
|
|
##
|
|
## $widget subwidget name
|
|
## name - the component widget name
|
|
## Returns the widget patch to the component widget name.
|
|
## Allows the user direct access to your subwidgets.
|
|
##
|
|
## THE USER SHOULD PROVIDE AT LEAST THE FOLLOWING:
|
|
##
|
|
## $NAMESPACE::construct {w} => return value ignored
|
|
## w - the widget name, also the name of the global data array
|
|
## This procedure is called by the public accessor (instantiation) proc
|
|
## right after creating all component widgets and populating the global $w
|
|
## array with all the default option values, the "base" key and the key
|
|
## names for any other components. The user should then grid/pack all
|
|
## subwidgets into $w. At this point, the initial configure has not
|
|
## occured, so the widget options are all the default. If this proc
|
|
## errors, so does the main creation routine, returning your error.
|
|
##
|
|
## $NAMESPACE::configure {w args} => return ignored (should be empty)
|
|
## w - the widget name, also the name of the global data array
|
|
## args - a list of key/vals (already verified to exist)
|
|
## The user should process the key/vals however they require If this
|
|
## proc errors, so does the main creation routine, returning your error.
|
|
##
|
|
## THE FOLLOWING IS OPTIONAL:
|
|
##
|
|
## $NAMESPACE::init {w} => return value ignored
|
|
## w - the widget name, also the name of the global data array
|
|
## This procedure is called after the public configure routine and after
|
|
## the "basecmd" key has been added to the $w array. Ideally, this proc
|
|
## would be used to do any widget specific one-time initialization.
|
|
##
|
|
## $NAMESPACE::destruct {w} => return ignored (should be empty)
|
|
## w - the widget name, also the name of the global data array
|
|
## A default destroy handler is provided that cleans up after the megawidget
|
|
## (all state info), but if special cleanup stuff is needed, you would provide
|
|
## it in this procedure. This is the first proc called in the default destroy
|
|
## handler.
|
|
##
|
|
|
|
namespace eval ::Widget::ScrolledText {;
|
|
|
|
;proc construct {w} {
|
|
upvar \#0 [namespace current]::$w data
|
|
|
|
grid $data(text) $data(yscrollbar) -sticky news
|
|
grid $data(xscrollbar) -sticky ew
|
|
grid columnconfig $w 0 -weight 1
|
|
grid rowconfig $w 0 -weight 1
|
|
grid remove $data(yscrollbar) $data(xscrollbar)
|
|
bind $data(text) <Configure> [namespace code [list resize $w 1]]
|
|
}
|
|
|
|
;proc configure {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
set truth {^(1|yes|true|on)$}
|
|
foreach {key val} $args {
|
|
switch -- $key {
|
|
-autoscrollbar {
|
|
set data($key) [regexp -nocase $truth $val]
|
|
if {$data($key)} {
|
|
resize $w 0
|
|
} else {
|
|
grid $data(xscrollbar)
|
|
grid $data(yscrollbar)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
# captures xview commands to the text widget
|
|
;proc _xview {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
if {[catch {uplevel $data(basecmd) xview $args} err]} {
|
|
return -code error $err
|
|
}
|
|
}
|
|
|
|
# captures yview commands to the text widget
|
|
;proc _yview {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
if {[catch {uplevel $data(basecmd) yview $args} err]} {
|
|
return -code error $err
|
|
} elseif {![winfo ismapped $data(xscrollbar)] && \
|
|
[string compare {0 1} [$data(basecmd) xview]]} {
|
|
## If the xscrollbar was unmapped, but is now needed, show it
|
|
grid $data(xscrollbar)
|
|
}
|
|
}
|
|
|
|
# captures insert commands to the text widget
|
|
;proc _insert {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
set code [catch {uplevel $data(basecmd) insert $args} err]
|
|
if {[winfo ismapped $w]} { resize $w 0 }
|
|
return -code $code $err
|
|
}
|
|
|
|
# captures delete commands to the text widget
|
|
;proc _delete {w args} {
|
|
upvar \#0 [namespace current]::$w data
|
|
set code [catch {uplevel $data(basecmd) delete $args} err]
|
|
if {[winfo ismapped $w]} { resize $w 1 }
|
|
return -code $code $err
|
|
}
|
|
|
|
# called when the ScrolledText widget is resized by the user or possibly
|
|
# needs the scrollbars (de|at)tached due to insert/delete.
|
|
;proc resize {w d} {
|
|
upvar \#0 [namespace current]::$w data
|
|
## Only when deleting should we consider removing the scrollbars
|
|
if {!$data(-autoscrollbar)} return
|
|
if {[string compare {0 1} [$data(basecmd) xview]]} {
|
|
grid $data(xscrollbar)
|
|
} elseif {$d} {
|
|
grid remove $data(xscrollbar)
|
|
}
|
|
if {[string compare {0 1} [$data(basecmd) yview]]} {
|
|
grid $data(yscrollbar)
|
|
} elseif {$d} {
|
|
grid remove $data(yscrollbar)
|
|
}
|
|
}
|
|
|
|
|
|
}; #end namespace ::Widget::ScrolledText
|