# xowidget.tcl --
#
#       This file contains a package that adds a megawidget framework using
#       XOTcl capabilities. All code is contained within the ::xowidget
#       namespace
#
#
# Copyright (c) 2004 Bryan Schofield
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
#
#
#
# TERMS AND DEFINITIONS
# Widget proc (widgetproc) -
#    Tcl level command that acts as the interface to a tk widget. For example,
#    when creating a button with the widget path ".b", ".b" is the widget proc
#    that is used to interact with the widget. [.b invoke].
#
# Widget path (widgetpath) -
#    Tk widget path to a widget. For example ".frame1.button1"
#
# Base widget (basewidget) -
#    The real tk widget widgetpath that a Widget class is built upon.
#
# Tk Widget Facade -
#    The Tk Widget like interface provided by WidgetClass & Widget that
#    emulates a standard tk widget. The facade should be completely compatible
#    with standard and expected tk widget behavior.
#
#
# CLASSES AND COMMANDS
#
# WidgetClass
#    Meta-class responsible for construction a Widget class, creating the
#    tk widget, hiding it, and generating a new "widget proc". WidgetClass
#    should be used instead of the standard meta-class, "Class" for
#    defining new Widgets
#
#
# Widget
#    The core class that makes the tk widget like behavior possible for XOTcl
#    classes. This class is resposponsible for handing widget proc command, as
#    well as options. All classes defined with the WidgetClass meta-class will
#    have Widget mixed-in. Widget class provides the following data memebers:
#
#    * widgetpath - the tk widget path to the "base" widget. Any child widgets
#                   of the basewidget should be childrend of "$widgetpath".
#    * widgetproc - the tcl level command that interfaces directly with the
#                   base widget. During construction, the base widget's 
#                   widgetproc is redefined so that a new one can be created
#                   allowing methods to be dispatched to the Widget
#                   object. There is no real need to access this directly
#                   since a "widgetproc" is available.
#    * tkcmds     - array of "tk level" commands. These are sub-commands
#                   available to the widgetproc as seen by the rest of
#                   tcl. The "tkcommand" command should be used to modify this
#                   array.
#    * tkopts     - array of "tk level" options. These are options available
#                   to the rest of tcl via the "cget" and "configure" methods.
#                   The "tkoption" command should be used to modify this
#                   array.
#    * optionHander - array of WidgetOption classes to key words. This is used
#                   when adding tk level options to the Widget.
#
#    Additionally, the following Widget object accessible commands are
#    defined. These commands are not available to the rest of tcl at the
#    widgetproc level.
#
#    * tkcommand  - for adding, removing, querying widgetproc subcommands. See
#                   below for usage.
#    * tkoption   - for adding, removing, querying widgetproc option available
#                   via "cget" and "configure". See below for usage.
#    * addWidgetprocOptions - convience short cut method useful for adding
#                   widgetproc options. This is a loop for:
#                   tk command add <opt> widgetproc -object [self]
#    * widgetproc - the interface to real basewidget.
#    * tk         - the widget subcommand dispatcher. All "tcl" level commands
#                   being called on the new widgetproc are routed through this
#                   method do determine assessibility. For example, if you
#                   have a new Widget object .foo and have the tkcommand "bar"
#                   registered, when the code [.foo bar] is evaluated, the
#                   .foo's XOTcl objects "tk" method will be invoked with to
#                   determine if "bar" is available to the caller.
#
#    Finally, the Widget class provides the tk standard "cget" and "configure"
#    methods that mimic the behavior found in the standard tk widgets. Widget
#    also provides binding on life cycle of the Widget and basewidget. Meaning
#    that destruction of one will cause immediate destruction of the other.
#
#
#
# WidgetOption
#    Abstract helper class for handling "tk" options accessible via "cget" and
#    "configure"
#
# ParameterOption
#    A WidgetOption that makes a XOTcl object parameters available as tk
#    options. Please note that the XOTcl object need not be the Widget
#    registering the option. In fact, it need not be a Widget class object at
#    all.
#
# WidgetprocOption
#    A WidgetOption that make options on a Widget's basewidget available. The
#    WidgetprocOption need be the Widget registering the option.
#
# TkWidgetOption
#    A WidgetOption that makes options of a tk widget avialable. Typically,
#    this is used expose options of a subcomponent in a Widget class.
#    
#
#
#
# USAGE
#
# Defining A New Widget.
#
#   WidgetClass MyWidget -tkwidget frame -parameter { {foo bar} {ack ick} }
#
#   The "tkwidget" parameter determines what type of tk widget to use to build
#   the newly defined Widget. Notice that the superclass of "Widget" is not
#   needed, WidgetClass will mix it in as needed. The "tkwidget" can be *any*
#   real tk widget *or* any mega-widget, such another Widget or  BWidget
#   mega-widget, that  conforms to the standard tk widget
#   interfaces. WidgetClass differs Class in that it forces the tk widget path
#   to be returned instead of the XOTcl object when an instance of a Widget is
#   created. For example, [MyWidget .m] will return ".m" and not "::.m". In
#   fact, the XOTcl object handle is not directly available, but can be
#   accessed as "::xowidget::<tk_widget_path>". Using our example here, the
#   XOTcl object is actually "::xowidget::.m"
#
#
# Providing basewidget construction arguments.
#
#   MyWidget tkWidgetCreationArgs -class MyWidget -borderwidth 0
#
#   It is sometimes beneficial to provide options to the base tk widget during
#   construction of the actual widget, such a the "-class" option a frame that
#   can only be set during creation.
#
#
# Defining a good constructor to your new Widget class.
#
#   The basic sequence of events for defining the construction of a Widget
#   class will look like this:
#
#   MyWidget instproc init {args} {
#      next
#      my instvar widgetpath
#      # build the ui
#      pack [label $widgetpath.l] [entry $widgetpath.e] -side left -fill x
#      # add options
#      ...
#      # add commands
#      ...
#      # initialize data memebers
#      my set smackaroo "bansia!"
#   }
#
#
# Adding options to your new Widget
#
#   MyWidget instproc init {args} {
#      next
#      my instvar widgetpath
#      ...
#      # add options,
#      # add background to my basewidget and to the label subcomponent
#      my tkoption add background widgetproc -object [self]
#      my tkoption add background tkwidget -widgetpath $widgetpath.l
#      # make my parameter "foo" available
#      my tkoption add foo parameter -object [self]
#      # make my parameter "ack" available but call it something else
#      my tkoption add scream parameter -object [self] -asoption ack
#      # make my label subcomponent text option available
#      my tkoption add text tkwidget -widgetpath $widgetpath.l
#      # make my label subcomponent foreground option available, under a
#      # different name
#      my tkoption labelfg tkwidget -widgetpath $widgetpath.l \ 
#           -asoption foreground
#      # pass all other options on to the entry subcomponent
#      my tkoption * tkwidget -widgetpath $widgetpath.e
#      ...
#   }
# 
#   Notice that "background" option is registered twice. When a configure or
#   cget request is made, both option handlers will be invoke in the order
#   registered. The result of last handler will be returned. In this case, if
#   "configure -background blue" is called, the basewidget widgetproc will be
#   invoked, then the label widgetproc will be invoked. The return value of
#   the label's configure will be returned.
#
#   Also notice the use of the special option value "*". This will cause any
#   configure or cget request for options not explicitly registered to be
#   based to tkwidget "$widgetpath.e". Please note that multiple wildcard
#   handlers can be registered, just like any other option. Finally, notice
#   that the "-asoption <value>" allows our widget to proxy one option as
#   another. Please also note that the "asoption" value DOES NOT have a
#   leading  dash (-s). Specifying "-asoption -something" is incorrect.
#
#
# Adding commands to your new Widget
#   
#   MyWidget instproc init {args} {
#      next
#      my instvar widgetpath
#      ..
#      # add commands
#      # make the ack parameter command available but under a different name
#      my command add scream "my ack"
#      # make the foo parameter command available
#      my command add foo
#      # pass all other commands on to the entry widget subcomponent. This
#      # will make our widget behaive like an entry.
#      my command add * "$widgetpath.e"
#      ...
#   }
#
#
# Creating an instance of your new Widget
#
#   pack [MyWidget .mw1 -ack "ackaroo!" -background blue -text "Enter:"]
#   MyWidget .mw2
#   .mw2 configure -text "Enter Something:" \ 
#      -labelfg "white" \ 
#      -background "grey30" \ 
#      -selectbackground "yellow" \ 
#      -selectforeground "black" \ 
#      -insertofftime 500
#
#   Notice that MyWidget constructor can be used like any tk widget since it
#   returns the a valid widget path and NOT an XOTcl object. Also notice the
#   use of wildcard options "selectbackground, selectforeground, and
#   insertofftime".
#
#
# Configuring and getting option values of Widget objects
#
#    MyWidget .m
#    .m configure -text "Foo"
#    puts "text cget: [.m cget -text]"
#    puts "text config: [.m configure -text]"
#    puts "all config: [.m configure]"
#
#    This conforms to the standard cget/configure interface.
#
# Invoking methods on Widget objects
#
#   MyWidget .m
#   .m get
#   .m delete 0 end
#   .m insert end "Foo"
#   .m foo "All your base are belong to us!"
#   .m scream "Ah! Man!"
#   puts "I scream: [.m scream]"
#
#   Notice the use of wildcard proxied methods to the entery widget. Also
#   notice the calls to the parameter foo, and alternatively named parameter
#   "scream". The call to "scream" actually will call parameter command "ack"
#
#
# Deleting a Widget
#
#   MyWidget .m
#   destroy .m
#
#   Treated just like a tk widget. Alternative, the XOTcl object could be
#   destroyed, though it is not as easily accessed:
#     ::xowidget::.m destroy
#
#
# Inheriting from an existing Widget
#
#    WidgetClass MySuperWidget -superclass MyWidget \ 
#      -parameter { {yahoo woopie} }
#    MySuperWidget instproc init {args} {
#       next
#       my tkcommand add yahoo
#       my tkoption add yahoo parameter -object [self]
#    }
#    MySuperWidget .super -foo "my base foo" -yahoo "YAHOO!"
#    .super configure -background red -labelfg white
#
#   Inheriting Widgets is no different from inherinting other XOTcl objects.
#
#
package require XOTcl 1.2
package require Tk

package provide xowidget 0.1


namespace eval ::xowidget {
   namespace export WidgetClass Widget
}
namespace eval ::xowidget::tk {}




#======================================================================
# WidgetClass
#======================================================================
::xotcl::Class ::xowidget::WidgetClass \
    -superclass ::xotcl::Class \
    -parameter {
       {tkwidget frame}
    }
::xowidget::WidgetClass instproc init {args} {
   ::xotcl::my set tkWidgetCreationArgs {}
   ::xotcl::next
}
::xowidget::WidgetClass instproc tkWidgetCreationArgs {list} {
   ::xotcl::my set tkWidgetCreationArgs $list
}
::xowidget::WidgetClass instproc create {path args} {
   # rename the object to exist in xowidget namespace so we can easily handle
   # creating the tk widget and not trample on the object, we also want to
   # postpone widget initialization until we add in the Widget class
   set obj [eval ::xotcl::next ::xowidget::$path -noinit]
   # make sure the object mixes in the Widget class. If we find that one of
   # it's super classes does, we need to make sure we adopt it's tkwidget and
   # tkWidgetCreationArgs
   set inheritNeeded 1
   set objclass [$obj info class]
   foreach superclass [$objclass info heritage] {
      if {[lsearch [$superclass info instmixin] "::xowidget::Widget"] != -1} {
	 ::xotcl::my tkwidget [$superclass tkwidget]
	 ::xotcl::my set tkWidgetCreationArgs \
	     [$superclass set tkWidgetCreationArgs]
	 set inheritNeeded 0
	 break
      }
   }
   if {$inheritNeeded} {
      $objclass instmixinappend ::xowidget::Widget
   }
   # create the tk widget, we'll need to insert the widget path
   ::xotcl::my instvar tkWidgetCreationArgs
   eval [linsert [::xotcl::my tkwidget] 1 $path] $tkWidgetCreationArgs
   # hide the widget proc from normal use
   rename $path ::xowidget::tk::$path
   # create a new widget proc that acts as a proxy to our object
   ::proc $path args "eval $obj tk \$args"
   # now set the tk widget path and widget proc in our object so we can
   # reference it later
   $obj set widgetproc ::xowidget::tk::$path
   $obj set widgetpath $path
   # now initialize the object
   eval $obj init $args
   # return a clean widget path so it seems as if we were a standard tk widget
   return $path
}


#======================================================================
# Widget
#======================================================================
::xotcl::Class ::xowidget::Widget
::xowidget::Widget instproc init {args} {
   # command publicly available to the tk widget facade
   ::xotcl::my array set tkcmds {}
   # options publicly available to the tk widget facade
   ::xotcl::my array set tkopts {}
   # option types and classes used to handle the options
   ::xotcl::my array set optionHandler {
      parameter  ::xowidget::ParameterOption
      widgetproc ::xowidget::WidgetprocOption
      tkwidget   ::xowidget::TkWidgetOption
   }
   # Automatically register "cget" and "configure" to ensure conformity to the
   # standard tk widget signature
   ::xotcl::my tkcommand add cget "::xotcl::my tkcget"
   ::xotcl::my tkcommand add configure "::xotcl::my tkconfig"
   # finish constructing our object
   ::xotcl::next
   # make sure we know when the widget is destroy
   ::xotcl::my instvar widgetpath
   bind $widgetpath <Destroy> [list [::xotcl::self] destroy]
   eval ::xotcl::my tkconfig $args
}
::xowidget::Widget instproc destroy {args} {
   ::xotcl::my instvar widgetpath tkopts
   # destroy all option handlers
   foreach opt [array names tkopts] {
      foreach obj $tkopts($opt) {
	 catch {$obj destroy}
      }
   }
   if {[winfo exists $widgetpath]} { destroy $widgetpath }
   ::xotcl::next
}

::xowidget::Widget instproc widgetproc {args} {
   # pass the arguments on to the hidden, real tk widget
   ::xotcl::my instvar widgetproc
   eval $widgetproc $args
}

::xowidget::Widget instproc tk {name args} {
   # delegation point for all command publically available to the tk widget
   # facade. Here commands are routed to their registered handlers. We also
   # check for the wildcard handler
   ::xotcl::my instvar tkcmds
   if {[info exists tkcmds($name)]} {
      return [eval ::xotcl::my DoTkCommand $name $args]
   } elseif {[info exists tkcmds(*)]} {
      return [eval ::xotcl::my DoTkCommand * $name $args]
   }
   return -code error \
       "bad option \"$name\": must be [join [lsort [array names tkcmds]] {, }]"
}

::xowidget::Widget instproc tkcommand {op args} {
   # add, remove, or get a tk method handler. The handlers registered here are
   # publically available to the tk widget facade
   ::xotcl::my instvar tkcmds
   switch -- $op {
      add    {return [eval ::xotcl::my AddTkCommand $args]}
      remove {return [eval ::xotcl::my RemoveTkCommand $args]}
      get    {return [eval ::xotcl::my GetTkCommand $args]}
      default {
	 return -code error "bad option \"$op\": must be add, remove, or get"
      }
   }
   return
}

::xowidget::Widget instproc tkoption {op args} {
   # add, remove, or get a tk method handler. The options registered here are
   # publically available to the tk widget facade via cget & configure
   switch -- $op {
      add    {return [eval ::xotcl::my AddTkOption $args]}
      remove {return [eval ::xotcl::my RemoveTkOption $args]}
      get    {return [eval ::xotcl::my GetTkOption $args]}
      default {
	 return -code error "bad option \"$op\": must be add, remove, or get"
      }
   }
   
}

::xowidget::Widget instproc addWidgetprocOptions {optList} {
   foreach opt $optList {
      if {[llength $opt] == 2} {
	 my tkoption add [lindex $opt 0] widgetproc \
	     -object [self] \
	     -asoption [lindex $opt 1]
      } else {
	 my tkoption add $opt widgetproc \
	     -object [self]
      }

   }
}

::xowidget::Widget instproc tkcget {opt} {
   # this is standard tk widget style "cget"
   # the wildcard option handler is checked for in the event that the option
   # was not explicitly registered
   ::xotcl::my instvar tkopts
   if {[info exist tkopts($opt)]} {
      return [::xotcl::my DoTkCget $opt $opt]
   } elseif {[info exist tkopts(-*)]} {
      return [::xotcl::my DoTkCget -* $opt]
   } else {
      return -code error "bad option \"$opt\": must be [join [lsort [array names tkopts]] {, }]"
   }
}

::xowidget::Widget instproc tkconfig {args} {
   # this is standard tk widget style "configure"
   # the wildcard option handler is checked for in the event that the option
   # was not explicitly registered
   ::xotcl::my instvar tkopts
   switch -- [llength $args] {
      0 {
	 return [::xotcl::my DoTkConfigGetAll]
      }
      1 {
	 set opt [lindex $args 0]
	 if {[info exist tkopts($opt)]} {
	    return [::xotcl::my DoTkConfigGetOne $opt $opt]
	 } elseif {[info exists tkopts(-*)]} {
	    return [::xotcl::my DoTkConfigGetOne -* $opt]
	 } else {
	    return -code error "bad option \"$opt\": must be [join [lsort [array names tkopts]] {, }]"
	 }
      }
      default {
	 for {set i 0} {$i < [llength $args]} {incr i} {
	    set opt [lindex $args $i]
	    incr i
	    if {$i >= [llength $args]} {
	       return -code error "value missing for option \"$opt\""
	    }
	    if {[info exist tkopts($opt)]} {
	       ::xotcl::my DoTkConfigSet $opt $opt [lindex $args $i]
	    } elseif {[info exists tkopts(-*)]} {
	       ::xotcl::my DoTkConfigSet -* $opt [lindex $args $i]
	    } else {
	       return -code error "bad option \"$opt\": must be [join [lsort [array names tkopts]] {, }]"
	    }
	 }
      }
   }
}

::xowidget::Widget instproc AddTkCommand {name {command ""}} {
   ::xotcl::my instvar tkcmds
   ::xotcl::my lappend tkcmds($name) [expr {$command eq ""?"::xotcl::my $name":$command}]
   return
}

::xowidget::Widget instproc RemoveTkCommand {name {command ""}} {
   ::xotcl::my instvar tkcmds
   # if we have no registered handler, do nothing
   if {![info exists tkcmds($name)]} { return 0 }
   if {$command eq ""} {
      # remove all command handlers
      unset tkcmds($name)
   } else {
      # remove a specific command handler
      set i [lsearch $tkcmds($name) $command]
      if {$i != -1} {
	 set tkcmds($name) [lreplace $tkcmds($name) $i $i]
      }
      # if there are no more handlers, get rid of the entry
      if {$tkcmds($name) eq ""} {
	 unset tkcmds($name)
      }
   }
   return 1
}

::xowidget::Widget instproc GetTkCommand {name} {
   ::xotcl::my instvar tkcmds
   return [expr {[info exists tkcmds($name)]?$tkcmds($name):""}]
}

::xowidget::Widget instproc DoTkCommand {name args} {
   ::xotcl::my instvar tkcmds
   set result {}
   foreach command $tkcmds($name) {
      set result [eval $command $args]
   }
   return $result
}

::xowidget::Widget instproc AddTkOption {opt type args} {
   ::xotcl::my instvar tkopts optionHandler
   if {![info exists optionHandler($type)]} {
      return -code error "invalid option type \"$type\", must be [join [lsort [array names optionHandler]] {, }]"
   }
   # construct a widget option using the specified type handler
   set obj [eval $optionHandler($type) new -childof [::xotcl::self] $args]
   lappend tkopts(-$opt) $obj
}

::xowidget::Widget instproc RemoveTkOption {opt {obj ""}} {
   ::xotcl::my instvar tkopts
   if {![info exists $tkopts($opt)]} {return}
   if {$obj eq ""} {
      foreach obj $tkopts($opt) {
	 $obj destroy
      }
   } else {
      set i [lsearch $tkopts($opt) $obj]
      if {$i != -1} {
	 $obj destroy
	 set tkopts($opt) [lreplace $tkopts($opt) $i $i]
      }
   }
   return
}

::xowidget::Widget instproc GetTkOption {opt} {
   ::xotcl::my instvar tkopts
   return [expr {[info exists tkopts(-$name)]?$tkopts(-$name):""}]
}

::xowidget::Widget instproc DoTkCget {opt asopt} {
   ::xotcl::my instvar tkopts
   set result {}
   foreach obj $tkopts($opt) {
      set result [$obj getvalue $asopt]
   }
   return $result
}

::xowidget::Widget instproc DoTkConfigGetAll {} {
   ::xotcl::my instvar tkopts
   set result {}
   foreach opt [array names tkopts] {
      if {$opt eq "-*"} {
	 foreach obj $tkopts($opt) {
	    set result [concat $result [$obj configuration]]
	 }
      } else {
	 lappend result [::xotcl::my DoTkConfigGetOne $opt $opt]
      }
   }
   return $result
}

::xowidget::Widget instproc DoTkConfigGetOne {opt asopt} {
   ::xotcl::my instvar tkopts
   set result {}
   foreach obj $tkopts($opt) {
      set result [$obj configuration $asopt]
   }
   return $result
}

::xowidget::Widget instproc DoTkConfigSet {opt asopt value} {
   ::xotcl::my instvar tkopts
   set result {}
   foreach obj $tkopts($opt) {
      set result [$obj setvalue $asopt $value]
   }
   return $result
}





#======================================================================
# Widget Option Classes
#======================================================================
::xotcl::Class ::xowidget::WidgetOption
::xowidget::WidgetOption abstract instproc getvalue {opt}
::xowidget::WidgetOption abstract instproc setvalue {opt value}
::xowidget::WidgetOption abstract instproc configuration {{opt ""}}


#============================================================
# XOTcl Object Parameter Type Option
#============================================================
::xotcl::Class ::xowidget::ParameterOption \
    -superclass ::xowidget::WidgetOption \
    -parameter {
       {object ""}
       {parameter ""}
       {default ""}
       {dbclass ""}
       {dbresource ""}
    }
::xowidget::ParameterOption instproc init {args} {
   ::xotcl::next
   ::xotcl::my instvar object parameter dbclass dbresource
   if {$dbclass eq ""} {set dbclass [string totitle $parameter]}
   if {$dbresource eq ""} {set dbresource $parameter}
}
::xowidget::ParameterOption instproc getvalue {opt} {
   ::xotcl::my instvar object parameter
   return [$object $parameter]
}
::xowidget::ParameterOption instproc setvalue {opt value} {
   ::xotcl::my instvar object parameter
   return [$object $parameter $value]
}
::xowidget::ParameterOption instproc configuration {{opt ""}} {
   ::xotcl::my instvar parameter dbresource dbclass default
   return [list [expr {$opt eq ""?$parameter:$opt}] $dbresource $dbclass $default [::xotcl::my getvalue ""]]
}


#============================================================
# Widget Class Widgetproc/Basewidget Type Option
#============================================================
::xotcl::Class ::xowidget::WidgetprocOption \
    -superclass ::xowidget::WidgetOption \
    -parameter {
       {object ""}
       {asoption ""}
    }
::xowidget::WidgetprocOption instproc init {args} {
   ::xotcl::next
}
::xowidget::WidgetprocOption instproc getvalue {opt} {
   ::xotcl::my instvar object asoption
   if {$asoption ne ""} { set opt -$asoption }
   return [$object widgetproc cget $opt]
}
::xowidget::WidgetprocOption instproc setvalue {opt value} {
   ::xotcl::my instvar object asoption
   if {$asoption ne ""} { set opt -$asoption }
   return [$object widgetproc configure $opt $value]
}
::xowidget::WidgetprocOption instproc configuration {{opt ""}} {
   ::xotcl::my instvar object asoption
   if {$asoption ne ""} { set opt -$asoption }
   return [eval $object widgetproc configure $opt]
}

#============================================================
# Tk Widget Type Option
#============================================================
::xotcl::Class ::xowidget::TkWidgetOption \
    -superclass ::xowidget::WidgetOption \
    -parameter {
       {widgetpath ""}
       {asoption ""}
    }
::xowidget::TkWidgetOption instproc init {args} {
   ::xotcl::next
}
::xowidget::TkWidgetOption instproc getvalue {opt} {
   ::xotcl::my instvar widgetpath asoption
   return [$widgetpath cget [expr {$asoption eq ""?$opt:"-$asoption"}]]
}
::xowidget::TkWidgetOption instproc setvalue {opt value} {
   ::xotcl::my instvar widgetpath asoption
   return [$widgetpath configure [expr {$asoption eq ""?$opt:"-$asoption"}] $value]
}
::xowidget::TkWidgetOption instproc configuration {{opt ""}} {
   ::xotcl::my instvar widgetpath asoption
   set config [eval $widgetpath configure [expr {$asoption eq ""?$opt:"-$asoption"}]]
   lset config 0 $opt
   return $config
}