[P.R.] ---- [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] #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\::configure {args} { foreach {-var val} $args { set [namespace current]\::[string trimleft ${-var} -] $val } } proc $newname\::cget {-var} { return [set [namespace current]\::[string trimleft ${-var} -]] } 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 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 It should be possible to set the options only at object crwation time and return an error if trying to set an unknown option later on. ---- [Category Object Orientation]