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

<<categories>> Object Orientation