**NAME**

''oowidgets'' - Tcl package to create megawidgets using Tcl object system [TclOO]

**DESCRIPTION**

This is yet another approach of creating megawidgets using [TclOO]. My first little project with [TclOO]. I had a look at [Read-Only Text Megawidget with TclOO] and [Megawidgets with TclOO] and then took some ideas from [A Scrolled Widget implemented with TclOO]. A lot of code is just stolen from these wiki pages ...

**Code**

So here my approximately 100 lines of code:

======
package require Tk
package provide oowidgets 0.1
namespace eval ::oowidgets { }

# this creates a wrapper around the class,
# so that object creation works like for other Tk widgets
proc oowidgets::new name { 
    eval "
    proc [string tolower $name] {path args}  { 
      set obj \[$name create tmp \$path {*}\$args\]
        rename \$obj ::\$path
        return \$path
    }
    "
}
# the BaseWidget from which your MegaWidgest should inherit
oo::class create ::oowidgets::BaseWidget {
      variable parentOptions ; # base widgets options
      variable widgetOptions ; # additional options

      variable widgettype
      constructor {path args} {
              my variable widgetOptions
              my variable parentOptions
              array set widgetOptions [list]
              array set parentOptions [list]
              #my configure {*}$args
      }
      # must be currently called in the constructor
      # of the inheriting class
      method install {wtype path args} {
          my variable parentOptions
          my variable widgetOptions
          my variable widget
          $wtype $path
          set widget ${path}_
          foreach opts [$path configure] {
              set opt [lindex $opts 0]
              set val [lindex $opts end]
              set parentOptions($opt) $val
          }
          array set nopts $args
          foreach opt [array names nopts] {
              set widgetOptions($opt) $nopts($opt)
          }
          rename $path $widget
      }
      # overwriting the standard methods cget and configure
      # to deal with possible new options
      method cget { {opt "" }  } {
              my variable widgetOptions
              my variable parentOptions
              if { [string length $opt] == 0 } {
                      return [lsort [list [array get parentOptions] {*}[array get widgetOptions]]]
              }
              if { [info exists widgetOptions($opt) ] } {
                      return $widgetOptions($opt)
              } elseif {[info exists parentOptions($opt)]} {
                      return $parentOptions($opt)
              } 
              return -code error "# unknown option"
      }
      
      method configure { args } {
              my variable widget
              my variable widgetOptions
              my variable parentOptions
              
              if {[llength $args] == 0}  {
                      return [lsort [list [array get parentOptions] {*}[array get widgetOptions]]]
              } elseif {[llength $args] == 1}  {
                   # return configuration value for this option
                   set opt $args
                   if { [info exists widgetOptions($opt) ] } {
                           return $widgetOptions($opt)
                   } elseif {[info exists parentOptions($opt)]} {
                         return $parentOptions($opt)
                   } else {
                       return -code error "# unkown option"
                   }
              }
              
              # error checking
              if {[expr {[llength $args]%2}] == 1}  {
                      return -code error "value for \"[lindex $args end]\" missing"
              }
              
              # process the new configuration options...
              array set opts $args
              
              foreach opt [array names opts] {
                      set val $opts($opt)
                      
                      # overwrite with new value
                      if { [info exists widgetOptions($opt)] } {
                              set widgetOptions($opt) $val
                      } elseif {[info exists parentOptions($opt)]} {
                            set parentOptions($opt) $val
                            $widget configure $opt $val 
                      } else {
                           return -code error "unknown configuration option: \"$opt\" specified"
                          
                      }
              }
      } 
      # delegate all other methods to the widget
      method unknown {args} {
           my variable widget
           $widget {*}$args
      }
}

======

**Examples**

Let's now use this code above to create two little widgets which extends the ttk::label and the ttk::button with a flash method:

======

namespace eval ::flash {}

# create the wrapper function 
# so this creates a proc flash::button
# Please note that uppercasing the class name is required
# the wrapper proc is all lowercase

oowidgets::new ::flash::Button 

# the actual implementation of our sample widget

oo::class create ::flash::Button {
    superclass oowidgets::BaseWidget

    constructor {path args} {
          # new options with their defaults are added at the end
          my install ttk::button $path -flashtime 500
          my configure {*}$args
    }
    # our extension method
    method flash {} {
        set ot [my cget -text]
        set ft [my cget -flashtime]
        for {set i 0} {$i < 5} {incr i} {
            my configure -text "......"
            update idletasks
            after $ft
            my configure -text $ot
            update idletasks
            after $ft
        }
        puts flashed
        my configure -text $ot
    }
}

# Now just for demonstration purposes a second widget

# wrapper method ::flash::label creation
oowidgets::new ::flash::Label

# implementation
oo::class create ::flash::Label {
    superclass oowidgets::BaseWidget
    constructor {path args} {
        my install ttk::label $path -flashtime 500
        my configure {*}$args
    }
    method flash {} {
        set fg [my cget -foreground]
        for {set i 0} {$i < 10} {incr i} {
            my configure -foreground red
            update idletasks
            after [my cget -flashtime]
            my configure -foreground $fg
            update idletasks
            after [my cget -flashtime]
        }
        puts labelflashed
    }
}
======

Now example code for widget use:

======
# creating an packing the widgets
set fb [flash::button .fb -text "Exit" -flashtime 100 -command exit]
pack $fb -side top -pady 10 -pady 10 -fill both -expand true
set fl [flash::label .fl -text "FlashLabel" -flashtime 200 -anchor center]
pack $fl -side top -padx 10 -pady 10 -fill both -expand true

# call by variable
$fb flash
puts "done 1"

# call by path
.fb flash
puts "done 2"

# the flash::label
# call by  path and then variable
.fl flash
$fl flash
# calling a standard function of ttk::button (via unknown)
$fb invoke
======

**TODO's**

   * getting rid of oowidget::new by just creating a method oowidget::class which creates the class code and the widget in one go (DONE, see below)
   * composite widget demo (the classical LabEntry)
   * mixin demo (flash as mixin, might be anyway better)

Here an idea to create the wrapper and the class in one step:

======
proc oowidgets::widget {name body} {
    oowidgets::new $name
    oo::class create $name $body 
    oo::define $name { superclass oowidgets::BaseWidget }
}
======

That way we can get rid of the new call and the superclass statement within our class definition. Let's create a bluelabel widget just for illustration purposes:

======
oowidgets::widget ::flash::BlueLabel {
    constructor {path args} {
        my install ttk::label $path -flashtime 500
        my configure {*}$args
    }
    method flash {} {
        set fg [my cget -foreground]
        for {set i 0} {$i < 10} {incr i} {
            my configure -foreground blue
            update idletasks
            after [my cget -flashtime]
            my configure -foreground $fg
            update idletasks
            after [my cget -flashtime]
        }
        puts labelflashed
    }
}
======

**Discussion**

[DDG] - 2023-03-18: May be I missed an implementation of megawidgets using TclOO which is in widespread used. Sorry if this is the case and I come here with an other one ... It was just thought as my first exercise using TclOO. With around 100 LOC the result seems to be really impressive - thanks to TclOO and its creators.