yao

Not to be confused with the other yao(s) — Yet another object system.

 proc -- args #
 -- {

wdb yao -- Yet Another Object system

Yet another object system for tcl. Objects are not procedures but instead tags containing a namespace for the class and the current object number, e.g.

 ::yao::dog::15

These tags are intended to be immutable and be stored in variables, e.g. as follows:

 set snoopy [object new dog]

In difference to other OO systems, objects are not procedures by themselves, but instead, procedure object is necessary to invoke them, e.g. as follows:

 object $snoopy bark

The data are stored in namespace of the class, e.g. as follows:

 ::yao::dog::body(::yao::dog::15).

No inheritance, but the idea of components and delegation stolen from Snit.

Configuration of options (configure, cget) without database access.

Delegation currently not yet automated with keyword. Code short and minimalistic for this forum.

For more info, see yao documentation!

 }

 package require Tcl 8.5

 #
 # debug
 #

 proc echo args {puts $args}
 proc aloud args {
  puts $args
  uplevel $args
 }
 proc sourceCode p {
  list proc $p [info args $p] [info body $p]
 }

 # 
 # namespace yao (Yet Another Object-system)
 # provides namespaces and methdos for OO
 # and is base for namespace ensemble object.
 # 

 namespace eval yao {
  variable count 0
  namespace export *
  namespace ensemble create\
    -command ::object\
    -unknown [namespace current]::unknown
 }

 #
 # object msg $obj $cmd ...
 # sends messages to $obj.
 # Methods are translated to procedures
 # where name of $obj is prepended.
 # This trick is stolen from Python.
 #

 proc yao::msg {obj cmd args} {
  namespace inscope [namespace qualifiers $obj]\
    [list $cmd $obj {*}$args]
 }

 #
 # if namespace ensemble object is called without proc,
 # but with $obj instead, then proc msg is assumed.
 #

 proc yao::unknown {cmd0 cmd1 args} {
  list [namespace current]::msg $cmd1
 }

 #
 # object class name -options ...
 # creates new class
 # the namespace of which is ::yao::$classname
 #

 proc yao::class {class args} {
  array set opt [concat {
    -options {}
  } $args]
  namespace eval $class {
    proc msg args\
      "[namespace qualifiers [namespace current]]::msg {*}\$args"
    variable body
    array set body {}
  }
  namespace inscope $class\
    [list variable options $opt(-options)]
  method $class cget key {
    variable body
    dict get $body($self) option $key
  }
  method $class configure args {
    variable body
    if {[llength $args] == 0} then {
      # msg obj configure
      dict get $body($self) option
    } elseif {[llength $args] == 1} then {
      # msg obj configure -simple
      lassign $args key
      list $key [msg $self cget $key]
    } else {
      # msg obj configure -simple yes
      lassign $args key val
      # check if option -simple exists
      msg $self cget $key
      dict set body($self) option $key $val
      list $key [msg $self cget $key]
    }
  }
  method $class var args {
    variable body
    if {[llength $args] == 2} then {
      dict set body($self) var {*}$args
      lindex $args end
    } else {
      dict get $body($self) var {*}$args
    }
  }
  method $class component {name cmd args} {
    variable body
    msg [dict get $body($self) var $name] $cmd {*}$args
  }
  method $class destroy {} {
    if {[info command destructor] ne {}} then {
      msg $self destructor
    }
    variable body
    unset body($self)
  }
  set class
 }

 proc yao::method {class method argl body} {
  proc [set class]::[set method] [concat self $argl] $body
  set method
 }

 proc yao::new {class args} {
  variable count
  set namespace [namespace current]::$class
  set name [set namespace]::[incr count]
  set options [set ${namespace}::options]
  array set option [concat $options $args]
  dict set [set namespace]::body($name) option [array get option]
  dict set [set namespace]::body($name) var {}
  if {[info command ${namespace}::constructor] ne ""} then {
    msg $name constructor
  }
  set name
 }

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

 proc yao::exists obj {
  info exists [namespace qualifiers $obj]::body($obj)
 }

 namespace eval yao::delegate {
  namespace import -force\
    [namespace qualifiers [namespace current]]::method
  namespace export *
  namespace ensemble create
 }

 proc yao::delegate::method {method class component} {
  object method $class $method args "
    msg \$self component $component $method {*}\$args
  "
  list method $method delegated in class $class to component $component
 }

 proc yao::delegate::option {option class component} {
  object method $class configure$option {} "
    msg \$self component $component configure $option\
      \[msg \$self cget $option]
  "
 }

 #
 # debug/test:
 #

 -- create class dog with option -color, default white

 object class dog -options {
  -color white
 }

 -- create constructor for class dog.

 object method dog constructor {} {
  # each dog shall have a component named tail -- see below
  object $self var tail [object new tail -length short]
  object $self component tail var dog $self
 }

 -- create method bark for class dog

 object method dog bark text {
  puts "dog $self barks -- {$text}"
 }

 -- create class tail with option -length, default short

 object class tail -options {
  -length long
 }

 -- create method wag for class tail

 object method tail wag {} {
  puts "tail of [object $self var dog] wags!"
 }

 set snoopy [object new dog -color black/white]

 -- here comes some code: {
  % set snoopy [object new dog -color black/white]
  ::yao::dog::10
  % object $snoopy cget -color
  black/white
  % object $snoopy bark woof
  dog ::yao::dog::10 barks -- {woof}
  % object $snoopy component tail configure
  -length short
  % object $snoopy component tail wag
  tail of ::yao::dog::10 wags!
 }