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

Updated 2005-02-17 09:42:41 by DDG


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



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

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

 o1 obj o2       ;# o2 inherits from o1
 % init red

 set myobj [obj new]      ;# new autonamed object

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

 o1 newchild o3           ;# new child object o2 "created namespace ::o1::o2, proc ::o1::o2::o2"
 o1 o3 instproc self {} {  ;# an method of o1::o3 object "proc ::o1::o3::self"
   puts [self_]
 o1 o3 self        ;# invoke method self of object o3
 % ::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

Category Object Orientation