Updated 2013-12-27 07:53:13 by RLE

GPS: Cobj is a minimal object system inspired by Gadgets and LOST. There are several versions here. I currently use a version of cobj in a Tk game that I'm writing.
  #! /usr/local/bin/tclsh8.3

  namespace eval ::cobj {}
  namespace eval ::cobj::obj {}

  proc ::cobj::obj {type args} {
  variable _cobj_methods 

  set methods {}
  set alength [llength $args]

        if {$alength >= 2} {
                for {set i 0} {$i < [expr {$alength - 1}]} {incr i} {
                append methods "\n$_cobj_methods([lindex $args $i])"
                }
        append methods "\n[lindex $args [expr {$alength - 1}]]" ;#(1)
        }

        if {$alength == 1} {
        set methods [lindex $args 0]
        }

  set _cobj_methods($type) $methods

        namespace eval ::$type {}
        
        proc ::$type {args} "
        #puts \$args
        
                switch -- \$args {
                $methods
                }

        "

  namespace export obj
  }

To use it do something like this:
  cobj::obj toys::ball {
  fun {return "This is fun!"}
  testing {return "This is only a test!"}
  }

  puts [toys::ball fun]
  puts [toys::ball testing]

  #toys::bat inherits toys::ball
  cobj::obj toys::bat toys::ball {

  homerun {return "You won the game!"}
  }

  puts [toys::bat homerun]
  puts [toys::bat fun]

RS: Really nice. If you discount blank lines and comments, the whole system fits in 24 lines of code. The point marked ;#(1) above seems to be equally expressed with lindex $argv end, isn't it?

What seems to be missing is arguments for methods. Maybe by changing the object proc template like this (The name type in the above source would be clearer if called instance, I suppose):
 proc ::$instance {{method {}} args} {
      switch -- \$method {
      $methods
      }

Another note: in the for loop, expr is redundant. The second arg to for will be evaluated by expr anyway, so make that
                for {set i 0} {$i < ($alength - 1)} {incr i} {

GPS: Thanks. I wish that I had known about expr being redundant in a for loop.

MS: a system with similar properties is
  namespace eval ::cobj2 {
      proc obj2 {type args} {
          set type [uplevel namespace current]::$type
          if {[llength $args] >= 2} {
              foreach parent [lrange $args 0 end-1] {
                  set imports [uplevel namespace parent $parent]::[namespace tail $parent]::*
                   append toEval "catch {namespace import $imports}\n"
              }
          }
          foreach {procName argLst body} [lindex $args end] {
              append toEval "proc $procName \{$argLst\} \{$body\}\n"
          }
           namespace eval ::$type [append toEval {namespace export *}]
      }
      namespace export obj2
  }

Remark: there is a slight change in syntax: you now call
  toys::ball::fun

instead of
  toys::ball fun

Properties:

  • Method inheritance, just like cobj - remark that only methods defined at creation time are inherited (wouldn't it be nice to have a dynamic way to import commands from other namespaces? "namespace inherit" or similar ...)
  • Updatable methods: if you change a method, it is automatically changed in all classes/objects that inherit from it - cobj does not have this property.
  • Objects are created in the "correct" namespaces, i.e., in the scope of the caller.

To test this system, type
  cobj2::obj2 toys::ball {
      fun {} {return "This is fun"}
      testing {} {return "This is only a test!"}
  }
  puts [toys::ball::fun]
  puts [toys::ball::testing]
  
  #toys::bat inherits toys::ball
  cobj2::obj2 toys::bat toys::ball {
      homerun {} {return "You won the game!"}
  }
  
  puts [toys::bat::homerun]
  puts [toys::bat::fun]
  
  cobj2::obj2 toys::new ::toys::bat {
      scream {} {return "I'm screaming!"}
  }
  puts [toys::new::scream]
  puts [toys::new::fun]
  puts [toys::new::homerun]

GPS: Here is a complete rewrite of cobj:
  #! /usr/local/bin/tclsh8.3

  namespace eval ::cobj3::obj {}

  proc ::cobj3::obj {type inherits args} {

        namespace eval ::$type {}
                proc ::$type {args} {        
                set com [lindex $args 0]
                set args [lindex $args 1]
                
                        switch $com {
                
                                children {
                                return [namespace children [lindex [info level 0] 0]]
                                }
                                        
                                destroy {
                                
                                        foreach m $args {
                                        catch {namespace delete "[lindex [info level 0] 0]::$m"}
                                        catch {[rename "[lindex [info level 0] 0]::$m" ""]}
                                        }
                                }

                                help {
                                return "Valid messages are destroy, and children."
                                }
                        }                                 
                }

  set methods [lindex $args 0]
  set methlen [llength $methods]


        for {set i 0} {$i < $methlen} {incr i 3} { 
        set subproc ":: $type :: [lindex $methods 0]"

        regsub -all { } $subproc "" subproc
        namespace eval $subproc {}
        
                proc $subproc "[lindex $methods 1]" "
                [lindex $methods 2]
                "
        set methods [lrange $methods 3 end]        
        }

        if {[llength $inherits] != 0} {

                foreach im $inherits {
                set ns ":: $type :: [namespace tail ::$im]"
                regsub -all { } $ns {} ns
                interp alias {} $ns {} $im
                
                set nschildren [namespace children ::$im]
                #puts $nschildren
                        
                        foreach child $nschildren {
                        set nschild ":: $type :: [namespace tail $child]"
                        regsub -all { } $nschild {} nschild
                        interp alias {} $nschild {} $child
                        }
                }

        }


  namespace export obj
  }

Example usage:
  cobj3::obj toys::kazoo {} {
  hello {} {return kazoo}
  }


  cobj3::obj toys::frisbee {toys::kazoo} {

  throw {rate} {return "throw $rate"}
  catch {} {return "catch"}
  sweat {amount} {return $amount} 
  }

  puts [::toys::frisbee::throw fast]
  puts [::toys::frisbee::catch]
  puts [::toys::frisbee::sweat "I'm sweating like a pig!  Well, not really, just for effect."]
  puts [::toys::kazoo::hello]

  #The toys::kazoo::hello proc has been inherited upon creation of toys::frisbee.
  puts [::toys::frisbee::hello]
                        
  #puts [info body ::toys::frisbee::sweat]

  ::toys::frisbee destroy hello                        
  #This shouldn't work if the above worked:
  #puts [::toys::frisbee::hello]

  puts [::toys::frisbee children]
  #puts [::toys::frisbee help]

George Peter Staplin - Well, I've been at it again. I wrote a new version that works like Itcl's class command, has instance variables, and supports class level inheritance. It's interesting to me looking back at how this has progressed.
  #! /usr/local/bin/tclsh8.3

  namespace eval ::cobj {
  variable _cobj_methods
  variable _cobj_vars
        proc obj {type vars methods} {
        variable _cobj_methods
        variable _cobj_vars
        set _cobj_methods($type) $methods
        set _cobj_vars($type) $vars
        set _variables {}
                foreach v $vars {
                append _variables "variable $v;"
                }

                namespace eval ::$type {}
                proc ::$type {object} "
                        namespace eval ::\$object {
                        $_variables
                        }
                        proc ::\$object {args} {
                        $_variables
                        set self \[namespace current\]
                                while {1} {
                                set flag \[lindex \$args 0\]
                                set value \[lindex \$args 1\]
                                        switch -- \$flag {
                                        $methods
                                        }
                                set args \[lrange \$args 2 end\]
                                        if {\[llength \$args\] == 0} {
                                        break
                                        }                                
                                }
                        }                        
                "
        }

        proc inherit {type type2} {
        variable _cobj_methods                
        variable _cobj_vars
                
        set new_methods $_cobj_methods($type2)
        set existing_methods $_cobj_methods($type)

        set methods "$new_methods \n $existing_methods"

        set new_vars $_cobj_vars($type2)
        set existing_vars $_cobj_vars($type)

        set vars "$new_vars $existing_vars"

        set _variables {}
                foreach v $vars {
                append _variables "variable $v;"
                }
                
                namespace eval ::$type {}
                proc ::$type {object} "
                        namespace eval ::\$object {
                        $_variables
                        }
                        proc ::\$object {args} {
                        $_variables
                        set self \[namespace current\]
                                while {1} {
                                set flag \[lindex \$args 0\]
                                set value \[lindex \$args 1\]
                                        switch -- \$flag {
                                        $methods
                                        }
                                set args \[lrange \$args 2 end\]
                                        if {\[llength \$args\] == 0} {
                                        break
                                        }                                
                                }
                        }                        
                "
        }

  namespace export obj 
  namespace export inherit
  } 

  cobj::obj toys::ball {brand intensity} {
  brand: {set brand $value} 
  kick: {set intensity $value}
  what {return "kick $brand $intensity"}
  }

  toys::ball fun

  fun brand: ballo kick: hard
  puts [fun what]

  toys::ball moderate::fun

  moderate::fun brand: {smallo ballo}
  moderate::fun kick: softly
  puts [moderate::fun what]


  cobj::obj toys::football {color} {
  color {set color $value}
  }

  cobj::inherit toys::football toys::ball

  toys::football tfootb

  tfootb brand: {shino ballo}
  puts [tfootb what]
  tfootb color: red
  puts [tfootb what_color]

George Peter Staplin - I decided to make a simpler object system that just supports instance variables and messages.
  proc cobj {cname vars messages} {
  regsub -all {(\$)} $messages {\\\1} messages
  set strSelf "set self \\\[lindex \\\[info level 0\\\] 0\\\]"
  append messages " default {return -code error {unknown message}}"
        proc $cname {iname} "
        foreach v {$vars} {
        append varList \"variable ::\${iname}::\$v; \"
        }
        namespace eval \$iname {}
                proc \$iname {mesg args} \"
                \$varList
                $strSelf
                        switch -- \\\$mesg {
                        $messages
                        }
                \"
        "
  }

#Test code:
  cobj cWorkers {age position} {setAge {set age [lindex $args 0]} age {return $age} setPosition {set position [lindex $args 0]} position {return $position}}

  cWorkers joe
  joe setAge 31
  joe setPosition chemist

  cWorkers bob
  bob setAge 22
  bob setPosition drifter
  puts "Bob is [bob age] years old and works as a [bob position].  Joe is [joe age] years old and works as a [joe position]."

Sat Sep 29 22:15:04 MDT 2001

I've decided that the code was getting too messy. So, I've tried to keep this version really simple. It supports instance variables, methods, and that's about it. I've decided that inheritance isn't very useful for my game, and I don't like the ways that I've implemented it in the past. Anyway, enjoy -GPS
  #!/usr/local/bin/tclsh8.3
  #cobj10

  proc cobj {obj vars methods} {
        set init_vars "\n"
        set init_procs "\n"

        foreach var $vars {
                append init_vars "variable $var;\n"
        }

        for {set i 0} {$i < [llength $methods]} {incr i} {
                set meth [lindex $methods $i]
                incr i
                append init_procs "proc $meth args {$init_vars\nset arg \[lindex \$args 0\]\n[lindex $methods $i]\n}\n"
 
        }
        proc $obj newObj "namespace eval ::\$newObj {$init_vars $init_procs}"
  }

  cobj person {age height weight} {
        setAge {set age $arg}
        setHeight {set height $arg}
        setWeight {set weight $arg}
        getInfo {return [list $age $height $weight]}
  }


  proc main {} {
        person George

        George::setAge 20
        George::setHeight "6' 2\""
        George::setWeight 302
        
        person Thomas
        
        Thomas::setAge 21
        Thomas::setHeight "5' 9\""
        Thomas::setWeight 170
        
        puts [George::getInfo]
        puts [Thomas::getInfo]
  }
  main