Summary  edit

See Also  edit

XOTcl binary extension written in C

Description  edit

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 object should be 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  edit

# 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

# a 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

prns::obj oc;# -> oc
oc configure -test testval -test2 testval2
oc cget -test ;# -> testval
prns::obj oc2 -test newval ;# -> oc2
oc2 cget -test ;# -> newval

oc2 set test ;# -> newval
oc2 set test foo

prns::obj oc3 -sample 1 -sample2 2 ;# oc3
oc3 cget -sample ;# 1
oc3 cget -sample2 ;# 2
oc3 cget -sample3 ;# Option -sample3 does not exist

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References