@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/tcltk/exec/widget.tcl

@@ -0,0 +1,975 @@
+## 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