[P.R.] ---- namespace eval prns { variable count 0 namespace export obj } # args: # name - name of new object # initcmd - constructor proc (fully-qualified name of any available proc) # ns - namespace where should be object created # obj X ;# create object X (namespace ::X,command ::X::X,interp alias ::X) # obj X {} ns ;# create object ns::X (namespace ::ns::X,command ::ns::X::X) # obj X ns::initobj_X ns2 ;#create object ns2::X in namespace ::ns2::X with constructor proc ns::initobj_X proc prns::obj {name {initcmd {}} {ns {}}} { variable count if {"$name" eq "new"} { set name _probj__$count } if {[llength $ns]} { set ns ::[string trim $ns ::] } set newname $ns\::${name} if {[lsearch [interp aliases] $newname] == "-1"} { init $name $ns $initcmd return [interp alias {} $newname {} $newname\::${name}] } else { return -code error "Object $newname already exist" } } proc prns::init {name ns initcmd} { variable count incr count set newname $ns\::${name} namespace eval $newname {} proc $newname\::[namespace tail $newname] {command args} { if {"$command" eq "set" || "$command" eq "unset"} { variable [lindex $args 0] } eval $command $args } proc $newname\::instvar args { foreach var $args { uplevel 1 variable $var } } proc $newname\::instproc args { eval proc $args } 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 <- alias is not created for child objects catch { interp alias {} [namespace qualifiers $dispcmd] {} } catch { rename [namespace qualifiers $dispcmd] {} } namespace delete [namespace current] return } proc $newname\::mixin {obj} { variable privvars variable privprocs 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 privprocs($cmd)]} {continue} #not export [self_] cmd if {[namespace tail [self_]] eq "$cmd"} {continue} #export only procs that are not defined in target obj #if {[namespace tail [info procs $targns\::${cmd}]] eq "$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} #now in privvars array #if {"$var" eq "privvars" || "$var" eq "privprocs"} {continue} #export only vars that are not defined in target obj #if {![llength [info vars $targns\::${var}]]} { .. } variable $var if {[array exists $var]} { upvar 0 $var arr variable $targns\::$var array set $targns\::$var [array get arr] } elseif {[catch {set $var}]} { variable $targns\::$var } else { variable $targns\::$var [set $var] } } return } proc $newname\::newchild {obj {initcmd {}}} { if {[string equal [info procs $obj] "$obj"]} { return -code error "Child $obj (or defined proc) already exist" } prns::init $obj [namespace current] $initcmd proc [namespace current]::$obj {args} { set mycmd [lindex [info level 0] 0] eval $mycmd\::[namespace tail $mycmd] $args } return [namespace current]::${obj} } proc $newname\::private {command args} { variable privvars variable privprocs if {"$command" eq "vars"} { foreach var $args { set privvars($var) "" } } elseif {"$command" eq "procs"} { foreach proc $args { set privprocs($proc) "" } } else { return -code error "Unknown command $command must be vars or procs " } } construct $newname $initcmd return } proc prns::construct {newname initcmd} { #not export auto created default object methods, to diferend objects #it slow down 2x time of object creation (not important for me) $newname\::private vars privvars privprocs $newname\::private procs private newchild init_ mixin destroy self_ my_ \ instproc instvar #optional constuctor init_ if {[llength [info commands [lindex $initcmd 0]]]} { eval proc $newname\::init_ args [list [info body [lindex $initcmd 0]]] #execute init_ proc eval $newname\::init_ [lrange $initcmd 1 end] } return } ---- Examples: obj o1 ;# create new object/class o1 "namespace ::o1 , object proc ::o1::o1, interp alias ::o1" o1 proc foo {} { ;# create an method of object "o1" named "foo" instvar colour set colour red return } o1 foo ;# invoke method foo o1 proc bar {} { instvar colour puts $colour } o1 bar % red o1 set colour blue o1 bar % blue o1 set colour % blue set myobj [obj new] ;# new autonamed object o1 mixin $myobj ;# export methods and variables from o1 to $myobj $myobj bar % blue o1 newchild o2 ;# new child object o2 "created namespace ::o1::o2, proc ::o1::o2::o2" o1 o2 proc boo {} { ;# an method of o1::o2 object "proc ::o1::o2::boo" puts [self_] } o1 o2 proc noexport {} { puts lallala } o1 o2 private procs noexport o1 o2 boo ;# invoke method boo of object o2 o1 o2 mixin o1 ;# export child "o2" methods (but not noexport proc) and vars to parent object "o1" o1 boo o1 destroy ;# destroy object o1 and it all childs obj o3 {} ns ;# create new object/class ::ns::o3 (in namespace ::ns::o3 , object proc ::ns::o3::o3, interp alias ::ns::o3) proc init_o4 {} { instvar foo bar boo private vars foo boo set foo foo set bar bar set boo boo return } set o4 [obj o4 ::init_o4 ns] ;# create new object ::ns::o4 with constructor proc ::init_o4 $o4 set foo $o4 set foo [$o4 set bar] set o5 [obj new] $o4 mixin $o5 $o5 set bar $o5 set foo