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

Updated 2003-05-07 22:36:23

P.R.


 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]
    #inconsistency  
    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
            continue
        }
        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\::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 
            return
        }
        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]
            return
        }
        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]
                    } 
                }
            return
        }
        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

 }

Examples:

 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 it all childs

Category Object Orientation