Obj

Object package is obj. These specialties:
The name of an object – such as ::obj::inst::1 – serves as its ID, including leading ::. Thus it cannot be renamed. Instead, its name is intended to be stored in a variable.
An object called without method uses its default method, that is returning its name. Thus, e.g. calling $e results in its name, e.g. ::obj::inst::1.
If an object of class line is asked for its dots with additional argument list – args – then, if it is empty, returns the names, and if not empty, applys every contained object dot to argment list, returning results in a list.
Methods and data of an object class reside inside a namespace. If desired, you define a regular procedure with the command obj inscope class proc {…} {…} – the resulting procedure is resides peacefully inside class without polluting global namespace.
Why not Itcl? – On development One Hand Content with Itcl, I experienced these drawbacks:
Heritage of methods works, but requires to “think around the corner”. I prefer delegation of methods to contained component as experienced with Snit (another OO extension).
With Itcl, inside objects, attributes are translated to local variables – which is dangerous because of name collision. In obj, all attributes are referred to with $self configure and so on.
With Itcl, inside objects, methods are translated to procedures – which is dangerous because of name collision. In Obj, all methods are referred to with $self method $argl ... and so on.
Speed. Objects are created by procedure reference instead procedure definitions. Package obj ist optimized for big num of quasi-anonymous data, hidden deeply inside namespace obj, referred to only by local variables or internal data inside other objects.
#
# obj -- minimalistic object orientation for Tcl
# usage: package require obj
#

package require Tcl 8.5
package provide obj 0.2

#
# namespace obj
# variable counter to calculate unique object name
# sub-namespace inst for object instances
# sub-namespace class for class namespaces
#

namespace eval obj {
  variable counter 0
  namespace eval inst {}
  namespace eval class {}
  namespace export *
}

namespace eval obj::find {
  namespace ensemble create
  namespace export *
}

proc obj::find::object class {
  append data\
    [namespace qualifiers [namespace current]]\
    ::class:: $class ::data
  array names $data ::obj::inst::*
}

proc obj::find::class {{pat *}} {
  set result {}
  foreach ns [namespace children\
                [namespace qualifiers\
                   [namespace current]]::class $pat] {
    lappend result [namespace tail $ns]
  }
  set result
}

#
# obj::info $object $what
# intended to use as method:
# $object info $what
# $object info ? tells what is provided.
#

proc obj::info {self {how ""} args} {
  if {[exists $self]} then {
    if {$how eq ""} then {
      set how ?
    }
    switch -exact -- $how {
      class {
        namespace tail [namespace qualifiers [namespace origin $self]]
      }
      exists {
        exists {*}$args
      }
      self - object {
        set self
      } 
      namespace {
        namespace qualifiers [namespace origin $self]
      } 
      instances {
        array names\
          [namespace qualifiers\
             [namespace origin $self]]::data ::obj::inst::*
      } 
      methods {
        set pat [lindex $args 0]
        if {$pat eq ""} then {
          set pat {[a-zA-Z0-9]*}
        }
        set result {}
        foreach m [set [info $self namespace]::data(methods)] {
          if {[string match $pat $m]} then {
            lappend result $m
          }
        }
        set result
      }
      args {
        set method {*}$args
        set proc [namespace qualifiers [namespace origin $self]]::$method
        set argl {}
        foreach arg [lrange [::info args $proc] 1 end] {
          if {[::info default $proc $arg defVar]} then {
            lappend argl [list $arg $defVar]
          } else {
            lappend argl $arg
          }
        }
        set argl
      }
      body {
        set method {*}$args
        set proc [namespace qualifiers [namespace origin $self]]::$method
        ::info body $proc
      }
      comment - # {
        set result {}
        foreach line [::split [$self info body {*}$args] \n] {
          set line [string trim $line]
          if {$line eq {}} then continue
          if {[string index $line 0] ne "#"} then break
          lappend result [string trim $line "# "]
        }
        set result [string trim [join $result \n]]
        set line [lindex [split $result \n] 0]
        if {[string is list -strict $line]} then {
          lassign $line a b c d e
          if {$a eq "delegate" &&
              $b eq "to" &&
              $c in [$self component] &&
              $d in {as ""} &&
              (($e eq "" && $d eq "") ||
               $e in [$self component $c info methods])} then {
            if {$e eq ""} then {
              set e [lindex [::info level 0] end]
            }
            append result " -->\n" [$self component $c info comment $e]
          }
        }
        set result
      }
      source - method {
        list [namespace origin method] [info $self class] {*}$args\
          [info $self args {*}$args] [info $self body {*}$args]
      }
      constructor {
        list [namespace current]::constructor [info $self class]\
          [info $self args __constructor] [info $self body __constructor]
      }
      destructor {
        list [namespace current]::destructor [info $self class]\
          [info $self body __destructor]
      }
      classes {
        set p [namespace origin $self]
        set ns [namespace qualifiers [namespace qualifiers $p]]
        set result {}
        foreach c [namespace children $ns] {
          lappend result [namespace tail $c]
        }
        set result
      }
      configuremethod - validatemethod {
        set option {*}$args
        list [namespace current]::$how [info $self class] $option\
          [info $self args [string range __$how 0 end-6]$option]\
          [info $self body [string range __$how 0 end-6]$option]
      }
      cgetmethod {
        set option {*}$args
        list [namespace current]::cgetmethod [info $self class] $option\
          [info $self body __cget$option]
      }
      options {
        set p [namespace qualifiers [namespace origin $self]]
        set arrayName ${p}::data(options)
        dict keys [set $arrayName]
      }
      common {
        set ns [namespace qualifiers [namespace origin $self]]
        set ${ns}::data(common)
      }
      data {
        set ns [namespace qualifiers [namespace origin $self]]
        set ${ns}::data($self)
      }
      private {
        dict keys [dict get [info $self data] private]
      }
      help - \? {
        list added/modified subcommands:\
          self class namespace instances methods body args\
          source method comment constructor destructor\
          options classes cgetmethod validatemethod\
          data private common help ?
      } 
      default {
        uplevel #0 [list ::info $how {*}$args]
      }
    } 
  } else {
    # obiously basic proc meant
    uplevel ::info $self {*}[concat $how $args]
  }
}

proc obj::_generate-object_ args {
  set class [namespace tail [lindex [::info level 0] 0]]
  new $class {*}$args
}

#
# obj::class $classname
# initializes $classname with basic methods
# as well as keywords my and our for methods inside only.
#

proc obj::class {class args} {
  namespace eval class::$class {
    # core procedure
    namespace export _root-object_
    proc _root-object_ {{method ::return} args} {
      $method [::lindex [::info level 0] 0] {*}$args
    }
    # data
    array set data {}
    set data(options) {}
    set data(common) {}
    set data(methods) {cget configure info destroy private common isa}
  }
  # import pre-defined procedures and methods
  namespace eval class::$class [::subst {
      namespace import\
        [::namespace current]::new\
        [::namespace current]::info\
        [::namespace current]::local\
        [::namespace current]::exists
    }]
  # define core methods
  method $class __constructor args # false
  method $class __destructor args # false
  #
  method $class isa class\
    [subst {expr {\$class eq "$class" ? true : false}}] false
  #
  method $class cget key {
    ::variable data
    if {$key ni $data(options)} then {
      ::return -code error "no valid option: $key"
    }
    $self __cget$key
    ::dict get $data($self) option $key
  } false 
  method $class configure {args} {
    ::variable data
    ::if {![::llength $args]} then {
      ::set result {}
      ::foreach {key val} [::dict get $data($self) option] {
        ::lappend result\
          [::list $key [::dict get $data(options) $key] [$self cget $key]]
      }
      ::set result
    } else {
      if {[::llength $args] == 1} then {
        if {$args ni $data(options)} then {
          ::return -code error "no valid option: $args"
        }
        ::list {*}$args\
          [::dict get $data(options) {*}$args]\
          [$self cget {*}$args]
      } else {
        ::foreach {key val} $args {
          if {$key ni $data(options)} then {
            ::return -code error "no valid option: $key"
          }
          $self __validate$key $val
          ::dict set data($self) option $key $val
          $self __configure$key $val
        }
      }
    }
  } false
  method $class component {{component {}} args} {
    ::variable data
    if {$component eq ""} then {
      set result {}
      foreach {key val} [::dict get $data($self) private] {
        if {[::info command $val] ne "" &&
            [::namespace qualifiers $val] eq "::obj::inst"} then {
          lappend result $key
        }
      }
      set result
    } else {
      [::dict get $data($self) private $component] {*}$args
    }
  } false
  method $class private args {
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys [::dict get $data($self) private]
    } elseif {[::llength $args] == 1} then {
      ::dict get $data($self) private {*}$args
    } else {
      ::dict set data($self) private {*}$args
      ::lindex $args end
    }
  } false
  method $class common args {
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys [::dict get $data(common)]
    } elseif {[::llength $args] == 1} then {
      ::dict get $data(common) {*}$args
    } else {
      ::dict set data(common) {*}$args
      ::lindex $args end
    }
  } false
  method $class destroy args {
    ::if {[exists $self]} then {
      set result [$self __destructor]
      ::variable data
      ::unset data($self)
      ::rename $self ""
      set result
    } else {
      # presumably a Tk widget was to destroy
      ::destroy $self {*}$args
    }
  } false
  # debugging purposes
  method $class inside args {{*}$args}
  # define special procedures our & my
  proc class::${class}::our args {
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys $data(common)
    } elseif {[::llength $args] == 1} then {
      ::dict get $data(common) {*}$args
    } else {
      ::dict set data(common) {*}$args
    }
  }
  proc class::${class}::my args {
    ::upvar self self
    ::variable data
    ::if {![::llength $args]} then {
      ::dict keys [::dict get $data($self) private]
    } elseif {[::llength $args] == 1} then {
      ::dict get $data($self) private {*}$args
    } else {
      ::dict set data($self) private {*}$args
      ::dict get $data($self) private [::lindex $args 0]
    }
  }
  proc class::${class}::!my {name args} {
    # removes key from dict,
    # returns value of previously destroyed key
    ::upvar self self
    ::variable data
    ::catch {::dict get $data($self) private $name {*}$args} result
    ::dict unset data($self) private $name {*}$args
    ::set result
  }
  proc class::${class}::?my {name args} {
    # shortcut for ::dict get [my $name {*}$args]
    ::upvar self self
    ::variable data
    ::dict get $data($self) private $name {*}$args
  }
  array set opt [concat {
      -configure {}
      -common {}
    } $args]
  foreach {key val} $opt(-configure) {
    configure $class $key $val
  }
  dict keys $opt(-common)
  set class::${class}::data(common) $opt(-common)
  list class $class
}

proc obj::common {class {key ?} args} {
  if {$key eq "?"} then {
    inscope $class "dict keys \$data(common)"
  } elseif {$args eq ""} then {
    inscope $class "dict get \$data(common) $key"
  } else {
    lassign $args val
    dict set class::${class}::data(common) $key $val
    list in class $class, common $key is $val
  }
}

proc obj::exists obj {
  if {[::info proc $obj] eq ""} then {
    return false
  }
  set ins [namespace current]::inst::*
  if {![string match $ins $obj]} then {
    return false
  }
  set cns [namespace current]::class::*
  if {![string match $cns [namespace origin $obj]]} then {
    return false
  }
  return true
}

#
# obj::method $class $method {...} {...}
# cares pf forbidden method names
#

proc obj::method {class {method {}} args} {
  if {$method eq ""} then {
    set result {}
    foreach p [::info procs [::namespace current]::class::${class}::*] {
      if {[string first __ $p] < 0 &&
          $p ni {configure destroy cget} &&
          [lindex [::info args $p] 0] eq "self"} then {
        lappend result [namespace tail $p]
      }
    }
    set result
  } elseif {$args eq {}} then {
    set m [namespace current]::class::${class}::$method
    if {[::info procs $m] ne $m} then {
      set result {}
      foreach p [::info procs $m] {
        lappend result [::namespace tail $p]
      }
      set result
    } else {
      ::list [::namespace origin method] $class $method\
        [lrange [info args $m] 1 end]\
        [info body $m]
    }
  } else {
    lassign $args argl body check
    if {![string is false -strict $check]} then {
      switch -glob -- $method\
        _root-object_ - __constructor - __destructor - destroy -\
        new - my - our - private - common - isa -\
        configure - cget - __configure-* - __cget-* - __validate-* {
        return -code error [list forbidden method name: $method, sorry!]
      }
      upvar [namespace current]::class::${class}::data data
      if {$method ni $data(methods)} then {
        lappend data(methods) $method
      }
      if {[::info command ::$method] ne ""} then {
        puts stderr\
          "Warning: method $method in class $class hides command ::$method"
      }
      set procName [namespace current]::class::${class}::$method
      if {[::info command $procName] ne "" &&
          [lindex [::info args $procName] 0] ne "self"} then {
        puts stderr\
          "Warning: method $method in class $class overwrites a procedure!"
      }
    }
    proc $class $method [concat self $argl] $body
    list method $class $method
  }
}

proc obj::proc args {
  if {[llength $args] == 3} then {
    ::proc {*}$args
  } elseif {[llength $args] == 4} then {
    inscope [lindex $args 0] ::proc {*}[lrange $args 1 end]
  } else {
    append err [::info level 0]\
      \n---\neither:\n\
      "proc name argl body"\
      \nor:\n\
      "proc class name argl body"
    return -code error $err
  }
}

#
# obj::constructor $classname {...} {...}
# obj::destructor $classname {...}
#

proc obj::constructor {class args body} {
  method $class __constructor $args $body false
  list constructor $class
}
proc obj::destructor {class body} {
  method $class __destructor {} $body false
  list destructor $class
}

#
# obj::new $class ?options ?more??
# options are recognized by leading -
# parsing options is stopped by --
# additional args for constructor can follow the options
#

proc obj::new {class args} {
  variable counter
  set objName [namespace current]::inst::[incr counter]
  namespace import -force class::${class}::_root-object_
  rename _root-object_ $objName
  dict set class::${class}::data($objName) option\
    [set class::${class}::data(options)]
  dict set class::${class}::data($objName) private {}
  set index 0
  foreach {key val} $args {
    if {[string index $key 0] ne "-" ||
	[string is double -strict $key]} then break
    if {$key eq "--"} then {
      incr index
      break
    }
    incr index 2
    dict set class::${class}::data($objName) option $key $val
  }
  $objName __constructor {*}[lrange $args $index end]
  set objName
}

#
# obj::local $class ...
# creates new object inside procedure body
# and manages that it destroys on leaving this procedure.
#

proc obj::local {class args} {
  set obj [new $class {*}$args]
  set name [string map {:: :} [list local object $obj]]
  uplevel [list set $name $obj]
  uplevel\
    [list trace add variable $name unset\
       "$obj destroy;#"]
  set obj
}

#
# obj::option $class $key ?$val?
# installs appropriate option for class
#

proc obj::configure {class key {val ""}} {
  if {[string index $key 0] ne "-"} then {
    set key -$key
  }
  dict set class::${class}::data(options) $key $val
  method $class __cget$key {} # false
  method $class __validate$key val # false
  method $class __configure$key val # false
  lappend [namespace current]::class::${class}::data(methods)\
    __configure$key __cget$key __validate$key
  list class $class has option $key with default $val 
}

#
# obj::cgetmethod $lass $key {...}
# obj::validatemethod $lass $key {...}
# obj::configuremethod $lass $key $val {...}
# intended for additional control.
# These procs are invoked by delegate option (below).
#

proc obj::cgetmethod {class {key ""} args} {
  if {$key eq ""} then {
    set result {}
    foreach m [::info procs [namespace current]::class::${class}::__cget-*] {	
      set opt [regexp -inline {[-][^.]+$} $m]
      set body [::info body $m]
      if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
        lappend result $opt
      }
    }
    set result
  } elseif {$args eq ""} then {
    list [namespace origin cgetmethod] $class $key\
      [::info body [namespace current]::class::${class}::__cget$key]
  } else {
    lassign $args body
    method $class __cget$key {} $body false
    list cgetmethod $class $key
  }
}

proc obj::configuremethod {class {key ""} {val ""} {body #}} {
  if {$key eq ""} then {
    set result {}
    foreach m [::info procs [namespace current]::class::${class}::__configure-*] {	
      set opt [regexp -inline {[-][^.]+$} $m]
      set body [::info body $m]
      if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
        lappend result $opt
      }
    }
    set result
  } elseif {$val eq ""} then {
    list [namespace origin configuremethod] $class $key\
      [lrange [::info args [namespace current]::class::${class}::__configure$key] 1 end]\
      [::info body [namespace current]::class::${class}::__configure$key]
  } else {
    method $class __configure$key $val $body false
    list configuremethod $class $key
  }
}

proc obj::validatemethod {class {key ""} {val ""} {body #}} {
  if {$key eq ""} then {
    set result {}
    foreach m [::info procs [namespace current]::class::${class}::__validate-*] {	
      set opt [regexp -inline {[-][^.]+$} $m]
      set body [::info body $m]
      if {[string trim [string trimleft [string trim $body] #]] ne ""} then {
        lappend result $opt
      }
    }
    set result
  } elseif {$val eq ""} then {
    list [namespace origin validatemethod] $class $key\
      [lrange [::info args [namespace current]::class::${class}::__validate$key] 1 end]\
      [::info body [namespace current]::class::${class}::__validate$key]
  } else {
    method $class __validate$key $val $body false
    list validatemethod $class $key
  }
}

proc obj::read-only {class key} {
  validatemethod $class $key val [subst -nocommand {
    return -code error\
      [list You tried to set \$val on\
	 read-only option $key of class $class.]
  }]
  list option $key of class $class is read-only.
}

#
# delegate methods & options to components
#

namespace eval obj {
  namespace eval delegate {
    namespace export *
    namespace ensemble create
  }
}

#
# obj::delegate method $method $class $component ?as-method?
#

proc obj::delegate::method {method class component {as ""}} {
  if {$as eq ""} then {
    set as $method
  }
  set ns [namespace qualifiers [namespace current]]
  ${ns}::method $class $method args [subst -nocommand {
    # delegate to $component as $as
    \$self component $component $as {*}\$args
  }]
  lappend result\
    class $class delegates method $method to component $component
  if {$as ne $method} then {
    lappend result as $as
  }
  set result
}

#
# obj::delegate option $option $class $component ?as-option?
#

proc obj::delegate::option {option class component {as ""}} {
  if {$as eq ""} then {
    set as $option
  }
  set ns [namespace qualifiers [namespace current]]
  ${ns}::configuremethod $class $option args [subst -nocommand {
    \$self component $component configure $as {*}\$args
  }]
  ${ns}::cgetmethod $class $option [subst -nocommand {
    variable data
    dict set data(\$self) option $option\
      [\$self component $component cget $as]
  }]
  list class $class delegates option $option to component $component\
    {*}[if {$as ne $option} then {list as $as}]
}

#
# obj::inscope $class cmd ...
#

proc obj::inscope {class args} {
  namespace inscope [namespace current]::class::$class {*}$args
}

proc obj::help {{cmd --}} {
  set procs ""
  foreach p [info procs [namespace current]::*] {
    if {[string first _ $p] < 0} then {
      lappend procs [namespace tail $p]
    }
  }
  if {$cmd ni $procs} then {
    set procs
  } else {
    set argl {}
    foreach arg [::info args $cmd] {
      if {[::info default $cmd $arg def]} then {
        lappend argl [list $arg $def]
      } else {
        lappend argl $arg
      }
    }
    list obj::$cmd $argl
  }
}
Einleitung
Bedienkonzept
Tastenkürzel
Menü
Tutorial
Software
- General
- Packages
  - Obj
  - XML
  - Bezier
- Dot
- Line
- Fill
- Group
- Canvaseditor
- GlassCube
- Main
- Constraints
Hinweise
Galerie
Notizen