oowidgets

Difference between version 25 and 27 - Previous - Next

**NAME**

''oowidgets'' - Tcl package to create megawidgets using inheritance, composition and mixins with the 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 ...

**Links**

    * Homepage: https://github.com/mittelmark/oowidgets
    * Download: https://github.com/mittelmark/oowidgets/archive/refs/heads/main.zip
    * Source: https://raw.githubusercontent.com/mittelmark/oowidgets/main/oowidgets/oowidgets.tcl
    * Tutorial: https://htmlpreview.github.io/?https://raw.githubusercontent.com/mittelmark/oowidgets/master/tutorial.html
    * Manual: https://htmlpreview.github.io/?https://raw.githubusercontent.com/mittelmark/oowidgets/master/oowidgets/oowidgets.html    * Demo Widgets: https://htmlpreview.github.io/?https://raw.githubusercontent.com/mittelmark/oowidgets/master/paul/basegui.html
    * Demo Application: https://github.com/mittelmark/oowidgets/blob/main/lisi/lisi-readme.md
    * Version: 0.5.0 - 2025-02-20
    * License: BSD

**Code (first version, Version 0.1)**

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 megawidget 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, DONE see below)
   * mixin demo (flash as mixin, might be anyway better, DONE see below)

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

**Composite Widgets**

Here a very basic variant of a composite widget consisting of a ttk::label and a ttk::entry within a frame.

======
oowidgets::widget ::flash::LEntry {
    variable ent
    variable lab
    constructor {path args} {
        # the main widget is the frame
        # add an additional label
        my install ttk::frame $path 
        set lab [ttk::label $path.lab]
        set ent [ttk::entry $path.ent]
        pack $lab -side left -padx 5 -pady 5
        pack $ent -side left -padx 5 -pady 5
        my configure {*}$args
    }
    # expose the internal widgets using subcommands
    method label {args} {
        $lab {*}$args
    }
    method entry {args} {
        $ent {*}$args
    }
    # you could as well delegate all methods to the entry widget
    # making it your default widget
    method unknown {args} {
        $ent {*}$args
    } 
}

# let's test
set test true
if {$test} {
    set le2 [flash::lentry .le2 -relief ridge -borderwidth 5]
    $le2 label configure -text "LEntry Example" -width 20
    $le2 entry configure -show *
    $le2 entry insert 0 "password"
    pack $le2 -side bottom -fill x -expand false
}
======

**Mixins**

Here a mixin example. Firstly we need to create a class for an existing tk or ttk widget, then we create the mixin lcass which should be not used to create any object on itself, it should be only used as mixin, then we use `oo::define` to add this mixin to our widget:

======
namespace eval ::oow { } 
# proxy class for ttk::label
oowidgets::widget ::oow::Label {
    constructor {path args} {
        my install ttk::label $path
        my configure {*}$args
    }
}   

# the mixin which should be not instantiated on its own
oo::class create ::oow::LblFlash {
    method flash {{flashtime 300}} {
        set fg [my cget -foreground]
        for {set i 0} {$i < 5} {incr i} {
            my configure -foreground green
            update idletasks
            after $flashtime
            my configure -foreground $fg
            update idletasks
            after $flashtime
        }
        puts "Mixin for label flashed" 
    }
}

# add mixin to our class
oo::define oow::Label { mixin ::oow::LblFlash }

# testing
if {1} {
    set lbl [oow::label .lbl -text "Hello" -foreground blue]
    pack  $lbl -side top 
    set btn [ttk::button .btn  -text "Exit" -command exit]
    pack $btn -side top
    $lbl flash
}
======

**Example Readonly Textwidget**

This is a rewrite based on the famous snit widget here on [Snit's Not Incr Tcl].

======
::oowidgets::widget Rotext {
    variable textw
    constructor {path args} {
        # we need the real widget
        set textw ${path}_
        # Create the text widget; turn off its insert cursor
        my install tk::text $path -insertwidth 0 -border 5 -relief flat
        my configure {*}$args
    }
    # Disable the text widget's insert and delete methods
    # to make this readonly even if the user writes text.
    method insert {args} { } 
    method delete {args} { }
    # programmatically we can still insert and delete ...
    method ins {args} { $textw insert {*}$args  }
    method del {args} { $textw delete {*}$args  }
}
======

**Unicode Widget**

Here an example which uses existing namespace code from this wikipage [Entering Unicode characters in a widget] and wraps this into an mixin which can be easily added. The code requires the latest oowidgets code available at https://github.com/mittelmark/oowidgets

======
package require oowidgets
# wrapper widget

namespace eval ::sample {}
oowidgets::widget ::sample::Text {
    constructor {path args} {
        my install tk::text $path
        my configure {*}$args
    }
}

namespace eval ::sample::unicode { 
    variable uc_keys
}

proc ::sample::unicode::enable_unicode_entry {widget} {
    variable uc_keys
    set uc_keys($widget) {}
}

proc ::sample::unicode::disable_unicode_entry {widget} {
    variable uc_keys
    unset -nocomplain uc_keys($widget)
}
proc ::sample::unicode::handle_uc_key {widget key} {
    variable uc_keys
    if {![info exists uc_keys($widget)]} {
        return
    }
    
    upvar 0 uc_keys($widget) keys
    switch -glob -- [string toupper $key] {
        {[0-9A-F]} {
            append keys $key
            if {[string length $keys] >= 4} {
                $widget insert insert [subst \\u$keys]
                disable_unicode_entry $widget
            }
            return -code break
        }
        default {
            $widget insert insert $keys
            disable_unicode_entry $widget
        }      
    }        
}


::oo::class create ::sample::txunicode {
    method unicode {{keypress Control-Key-u}} {
        set w [my widget]
        bindtags $w [list $w UnicodeEntry Text . all]
        bind UnicodeEntry <$keypress> [list ::sample::unicode::enable_unicode_entry %W]
        bind UnicodeEntry <Key> [list ::sample::unicode::handle_uc_key %W %A]
    }
}

# testing

if {true} {
  set txt [sample::text .txtu -background grey80 -font "Courier 18"]
  $txt insert  end "Press Ctrl-Shift-u and then thereafter 4 numbers like 2602\n\n"
  oo::objdefine $txt mixin sample::txunicode
  $txt unicode Control-Key-U ;# To use Control-Shift-u
  pack $txt -side top -fill both -expand yes
}
======

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

[DDG] - 2023-08-26: Bugfix for configuring non existing options for the  parent widget

[DDG] - 2024-12-28: Bugfix for delegation of arguments, basegui with method fontSizeBind to enable for all widgets font resize with Control-plus and Control-minus.

[DDG] - Version 0.4.0 - 2024-12-30: Making the Package Tcl 9 aware.
[DDG] - Version 0.5.0 - 2025-02-20: adding public command mixin, protected command option,  within the paul package more example widgets and mixins (imedit, labentry, tvmixins (- treeview mixins) and adding as well a sample application  'lisi' - graphics made easy.

----

<<categories>>Tk | TclOO | Widget