Version 21 of another minimal Tcl object system (XOTcl like syntax)

Updated 2013-03-17 12:43:38 by pooryorick


by P.R.

See Also

XOTcl binary extension written in C


namespace eval prns {
    variable count 0
    namespace export obj 

# args:
# name - name of new object
# ?-initcmd procname   - additional constructor proc (fully-qualified name of any available proc)
# ?-ns nsname   - namespace where should be object created
# ?-var1 val ?-var2 val  - initial variables
# obj X    ;# create object X (namespace ::X,command ::X::X,interp alias ::X)
# obj Y -ns myns  ;# create object myns::Y (namespace ::myns::Y,command ::ns::X::Y, interp alias ::Y)

proc prns::obj {name args} {
   if {"$name" eq "new"} {
       set name _obj__[incr prns::count]
   set newname [eval init $name $args]
   if {[lsearch [info commands] $name] == -1} {
       return [interp alias {} $name {} $newname\::$name]
   } else {
       return $newname\::$name

proc prns::init {name args} {
   set ns {} 
   set initcmd {} 

   if { [set idx [lsearch $args "-ns"]] != -1} {
       set ns ::[string trim [lindex $args [incr idx]] ::]

   set newname $ns\::$name

   namespace eval $newname {} 
   foreach {-var val} $args {
       if {${-var} eq "-ns"} {continue}
       if {${-var} eq "-initcmd"} {
           set initcmd $val
       if {[string index ${-var} 0] eq "-" && [string match {-*} ${-var}]} {
           variable $newname\::[string trimleft ${-var} -] $val

       proc $newname\::[namespace tail $newname] {command args} {
           if {"$command" eq "set" || "$command" eq "unset"} {
              variable [lindex $args 0] 
           eval $command $args  
       #proc $newname\::new args {
       #    eval prns::obj _obj__[incr prns::count] -ns [namespace current] $args 
       proc $newname\::obj {name args} {
           set newobj [eval prns::obj $name $args]
           [self_] mixin $newobj
           if {[llength [info procs [$newobj namespace current]::init]]} {
               namespace inscope [$newobj namespace current] init
           return $newobj
       proc $newname\::configure {args} {
           foreach {-var val} $args {
               set [namespace current]\::[string trimleft ${-var} -] $val
       proc $newname\::cget {-var} {
           if {[info exists [namespace current]\::[string trimleft ${-var} -]]} {
               return [set [namespace current]\::[string trimleft ${-var} -]]
           } else {
               return -code error "Option ${-var} does not exist"
       proc $newname\::info_ {cmd args} {
           switch -- $cmd {
               parent  {return [namespace parent]::[namespace tail [namespace parent]]}
               childs { set l {}
                       foreach chld [namespace children] {
                           lappend l [namespace tail $chld]
                       return $l
               vars  {  set l {}
                       foreach var [::info vars [namespace current]::*] {
                           lappend l [namespace tail $var]
                       return $l
               default {eval ::info $cmd $args}
       proc $newname\::instvar args {
           foreach var $args {
               uplevel 1 variable $var 
       proc $newname\::instproc args {
       variable expprocs
           eval proc $args
           set expprocs([lindex $args 0]) 1 
       proc $newname\::my_ args {
           eval [self_] $args 
       proc $newname\::self_ {} {
           return [namespace current]::[namespace tail [namespace current]] 
       proc $newname\::destroy {} {
           set dispcmd [lindex [info level -1] 0]
           catch { interp alias {} [namespace qualifiers $dispcmd] {} }
           catch { rename [namespace qualifiers $dispcmd] {} }
           namespace delete [namespace current]
       proc $newname\::mixin {obj} {
       variable privvars
       variable expprocs
           if {![string equal [info commands $obj] "$obj"]} {
               return -code error "Target object $obj not exist"
               set currns [namespace current] 
               set targns [$obj namespace current]
               foreach cmd [info procs ${currns}::*] {
                   set cmd [namespace tail $cmd]
                   if {![info exists expprocs($cmd)]} {continue}
                       set pargs ""
                       foreach arg [info args $cmd] {
                           if {[info default $cmd $arg defval]} {
                               append pargs "\{$arg \{$defval\}\} "
                           } else {
                               append pargs "$arg "
                   eval proc $targns\::$cmd [list $pargs] [list [info body $cmd]]
               foreach var [info vars ${currns}::*] {
                   set var [namespace tail $var]
                   if {[info exists privvars($var)]} {continue}
                   variable $var
                   if {[array exists $var]} {
                       upvar 0 $var arr
                       variable $targns\::$var
                       array set $targns\::$var [array get arr]
                   } elseif {[exists $var]} {
                       variable $targns\::$var [set $var]
       proc $newname\::newchild {objnew args} {
           if {[info procs $objnew] eq "$objnew"} {
               return -code error "Child $objnew (proc) already exist"
           set obj [eval prns::init $objnew -ns [namespace current] $args]
           proc [namespace current]::$objnew args {
               set mycmd [lindex [info level 0] 0]
               eval $mycmd\::[namespace tail $mycmd] $args           
            return $obj
       proc $newname\::exists {var} {
           variable $var
           if {[array exists $var]} {
               return 1
           return [info exists $var]
       proc $newname\::privvar {args} {
       variable privvars
           foreach var $args {
               set privvars($var) ""
   if {[llength [info commands [lindex $initcmd 0]]]} {
       eval proc $newname\::init__ args [list [info body [lindex $initcmd 0]]]
       #execute additional init proc
       eval $newname\::init__ [lrange $initcmd 1 end]

   return $newname



# create new object/class o1 "namespace ::o1 , object proc ::o1::o1, interp alias ::o1"
prns::obj o1 -color red
o1 instproc foo {} {    ;# create method of object "o1" named "foo"
    instvar color 
    puts $color

# invoke method foo
o1 foo
# -> red

# constructor proc
o1 instproc init args {
    puts "init [my_ set color]"

# o2 inherits from o1
o1 obj o2
# -> init red

# new autonamed object
set myobj [prns::obj new]

# export methods and variables from o1 to $myobj
o1 mixin $myobj

# new child object o2 "created namespace ::o1::o2, proc ::o1::o2::o2"
o1 newchild o3

# an method of o1::o3 object "proc ::o1::o3::self"
o1 o3 instproc self {} {
    puts [self_]

# invoke method self of object o3
o1 o3 self
# -> ::o1::o3::o3
o1 o3 mixin o1   ;# export child "o3" methods and vars to parent object "o1"
o1 self
# -> ::o1::o1
o1 destroy       ;# destroy object o1 and all its children

DDG This looks really nice. However I missed the methods configure and cget (although I think they are not xotcl like ...). So I was adding them: Now this is possible:

prns::obj oc;# -> oc
oc configure -test testval -test2 testval2
oc cget -test ;# -> testval
prns::obj oc2 -test newval ;# -> oc2
oc2 cget -test ;# -> newval

Personally I like this more than:

oc2 set test ;# -> newval
oc2 set test foo

Because you can configure more than one option in one command.

It should be possible to set the options only at object creation time and return an error if trying to set an unknown option later on.

DDG 2004-02-17: Added check if option exists for cget. A Question of Design: Should be options created only at object creation ?

prns::obj oc3 -sample 1 -sample2 2 ;# oc3
oc3 cget -sample ;# 1
oc3 cget -sample2 ;# 2
oc3 cget -sample3 ;# Option -sample3 does not exist