## Barebones requirements for creating and querying megawidgets
##
## Copyright 1997-8 Jeffrey Hobbs, jeff.hobbs@acm.org
##
## Initiated: 5 June 1997
## Last Update: 1998
##
## Updated 1st December 1998 by jkb to remove the requirement for the
## ::Utility package by including the two required functions in this file.

package require Tk 8
#package require ::Utility
package provide Widget 2.0

init_images

##------------------------------------------------------------------------
## 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*

#
# Taken from Jeffrey Hobbs' util.tcl file
#
# get_opts2 --
#
#   Process options into an array.  -- short-circuits the processing
#
# Arguments:
#   var		variable into which option values should be stored
#   arglist	argument list to parse
#   optlist	list of valid options with default value
#   typelist	optional list of option types that can be used to
#		validate incoming options
# Results:
#   Returns unprocessed arguments.
#
;proc get_opts2 {var arglist optlist {typelist {}}} {
    upvar 1 $var data

    if {![llength $optlist] || ![llength $arglist]} { return $arglist }
    array set data $optlist
    array set types $typelist
    foreach {key val} $arglist {
	if {[string match -- $key]} {
	    set arglist [lreplace $arglist 0 0]
	    break
	}
	if {[string match {} [set akey [array names data $key]]]} {
	    set akey [array names data ${key}*]
	}
	switch [llength $akey] {
	    0		{ ## oops, no keys matched
		return -code error "unknown switch '$key', must be:\
			[join [array names data] {, }]"
	    }
	    1		{ ## Perfect, found just the right key
		if {[info exists types($akey)] && \
			![validate $types($akey) $val]} {
		    return -code error "the value for \"$akey\" is not in\
			    proper $types($akey) format"
		}
		set data($akey) $val
	    }
	    default	{ ## Oops, matches too many possible keys
		return -code error "ambiguous option \"$key\",\
			must be one of: [join $akey {, }]"
	    }
	}
	set arglist [lreplace $arglist 0 1]
    }
    return $arglist
}

# validate --
# This procedure validates particular types of numbers/formats
#
# Arguments:
# type		- The type of validation (alphabetic, alphanumeric, date,
#		hex, integer, numeric, real).  Date is always strict.
# val		- The value to be validated
#
# Returns:	0 or 1 (whether or not it resembles the type)
#
# Switches:
# -incomplete	enable less precise (strict) pattern matching on number
#		useful for when the number might be half-entered
#
# Example use:	validate real 55e-5
#		validate -incomplete integer -505
#

;proc validate {args} {
    if {[string match [lindex $args 0]* "-incomplete"]} {
	set strict 0
	set opt *
	set args [lreplace $args 0 0]
    } else {
	set strict 1
	set opt +
    }

    if {[llength $args] != 2} {
	return -code error "wrong \# args: should be\
		\"[lindex [info level 0] 0] ?-incomplete? type value\""
    } else {
	set type [lindex $args 0]
	set val  [lindex $args 1]
    }

    ## This is a big switch for speed reasons
    switch -glob -- $type {
	alphab*	{ # alphabetic
	    return [regexp -nocase "^\[a-z\]$opt\$" $val]
	}
	alphan* { # alphanumeric
	    return [regexp -nocase "^\[a-z0-9\]$opt\$" $val]
	}
	b*	{ # boolean - would be nice if it were more than 0/1
	    return [regexp "^\[01\]$opt\$" $val]
	}
	d*	{ # date - always strict
	    return [expr {![catch {clock scan $val}]}]
	}
	h*	{ # hexadecimal
	    return [regexp -nocase "^(0x)?\[0-9a-f\]$opt\$" $val]
	}
	i*	{ # integer
	    return [regexp "^\[-+\]?\[0-9\]$opt\$" $val]
	}
	n*	{ # numeric
	    return [regexp "^\[0-9\]$opt\$" $val]
	}
	rea*	{ # real
	    return [regexp -nocase [expr {$strict
	    ?{^[-+]?([0-9]+\.?[0-9]*|[0-9]*\.?[0-9]+)(e[-+]?[0-9]+)?$}
	    :{^[-+]?[0-9]*\.?[0-9]*([0-9]\.?e[-+]?[0-9]*)?$}}] $val]
	}
	reg*	{ # regexp
	    return [expr {![catch {regexp $val {}}]}]
	}
	val*	{ # value
	    return [expr {![catch {expr {1*$val}}]}]
	}
	l*	{ # list
	    return [expr {![catch {llength $val}]}]
	}
	w*	{ # widget
	    return [winfo exists $val]
	}
	default {
	    return -code error "bad [lindex [info level 0] 0] type \"$type\":\
		    \nmust be [join [lsort {alphabetic alphanumeric date \
		    hexadecimal integer numeric real value \
		    list boolean}] {, }]"
	}
    }
    return
}

;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 }
