namespace eval prns {
variable count 0
namespace export obj
}
# args:
# name - name of new object
# initcmd - <optional> constructor proc (fully-qualified name of any available proc)
# ns - <optional> 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\::exists {var} {
variable $var
return [info exists $var]
}
#clear all methods and vars (leave de4fined in priv* arrays and child objects proc)
proc $newname\::clear {} {
variable privvars
variable privprocs
set currns [namespace current]
foreach cmd [info procs ${currns}::*] {
set cmd [namespace tail $cmd]
if {[namespace tail [self_]] eq "$cmd"} {continue}
if {[lsearch [namespace tail [namespace children [namespace current]]] "$cmd"] != "-1"} {
continue
}
if {![info exists privprocs($cmd)]} {
rename $cmd {}
}
}
foreach var [info vars ${currns}::*] {
set var [namespace tail $var]
if {![info exists privvars($var)]} {
variable $var {}
}
}
}
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 clear
#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