** Summary **

by [P.R.]

** See Also **

   [XOTcl] binary extension written in C:   

** Description **

======
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 [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 "-"} {
           variable $newname\::[string trimleft ${-var} -] $val
       }
   }

   proc $newname\::[namespace tail $newname] {command args} {
       if {$command eq "set" || $command eq "unset"} {
          variable [lindex $args 0] 
       }
       $command {*}$args  
   }

   #proc $newname\::new args {
   #    eval prns::obj _obj__[incr prns::count] -ns [namespace current] $args 
   #}

   proc $newname\::obj {name args} {
       set newobj [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 {::info $cmd {*}$args}
       }
   }

   proc $newname\::instvar args {
       foreach var $args {
           uplevel 1 variable $var 
       }
   } 

   proc $newname\::instproc args {
       variable expprocs
       proc {*}$args
       set expprocs([lindex $args 0]) 1 
       return
   }

   proc $newname\::my_ args {
       [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 "
                   }
               }
           proc $targns\::$cmd $pargs [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 [prns::init $objnew -ns [namespace current] {*}$args]
       proc [namespace current]::$objnew args {
           set mycmd [lindex [info level 0] 0]
           $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]]]} {
       proc $newname\::init__ args [info body [lindex $initcmd 0]]
       #execute additional init proc
       $newname\::init__ {*}[lrange $initcmd 1 end]

   }
   
   return $newname

}
======

** Examples **

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

# invoke method foo
o1 foo
# -> red

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

# o2 inherits from o1
o1 obj o2
# -> init red

# new autonamed object
set myobj [prns::obj new]

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

# new child object o2 "created namespace ::o1::o2, proc ::o1::o2::o2"
o1 newchild o3

# an method of o1::o3 object "proc ::o1::o3::self"
o1 o3 instproc self {} {
    puts [self_]
} 

# invoke method self of object o3
o1 o3 self
# -> ::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
======

<<categories>> Object Orientation