JBR's tcloo.tcl

Updated 2017-12-08

proc oo::define::public { method args } {
    set class [oo::_setup_helper]

    switch -glob $method {
        classvar {
          foreach { name value } $args {
              uplevel 1 [list classvar $name $value]
              uplevel 1 [subst { public method $name args { set $name {*}\$args } }]
          }
        }
        var* {
          foreach { name value } $args {
              uplevel 1 [list variable $name]
              uplevel 1 [subst { public method $name args { set $name {*}\$args } }]
              lappend [$class varname __variable] $name $value
          } 
        }
        method {
          lassign $args name args body
          uplevel 1 [list method $name $args $body]
          uplevel 1 [list export $name]
        }
        proc {
          lassign $args name args body
          uplevel 1 [list proc $name $args $body]
          uplevel 1 [list export $name]
        }
    }
}  
proc oo::define::private { method args } {
    set class [oo::_setup_helper]

    switch -glob $method {
        classvar {
          foreach { name value } $args {
              uplevel 1 [list classvar $name $value]
          }
        }

        var* { 
          foreach { name value } $args {
              uplevel 1 [list variable $name]
              lappend [$class varname __variable] $name $value
          }
        }
        method {
          lassign $args name args body
          uplevel 1 [list method $name $args $body]
          uplevel 1 [list unexport $name]
        } 
        proc {
          lassign $args name args body
          uplevel 1 [list proc $name $args $body]
          uplevel 1 [list unexport $name]
        } 
    }
} 
proc oo::define::classvar { args } {
    set class [oo::_setup_helper]

    foreach { name value } $args {
        uplevel 1 [list variable $name]
        set [$class varname $name] $value
        lappend [$class varname __classvar] $name
    }
}
proc oo::define::linked { args } {
    set class [lindex [info level -1] 1]
    oo::define $class { self export varname }

    if { [lindex $args 0] ne "method" } {
        set method [lindex $args 2]             ; # Skip over public / private
    } else {
        set method [lindex $args 1]
    }

    lappend [$class varname __linked] $method   ; # remember linked methods

    uplevel 1 $args
}
proc oo::define::proc { args } {
    set class [lindex [info level -1] 1]
    oo::define $class { self export varname }

    lappend [$class varname __linked] [lindex $args 0]  ; # remember linked methods

    uplevel 1 [list method {*}$args]
}
proc oo::_classvar { class varname } {
     [info object class $class] varname $varname
}
proc oo::_get_classvar { class varname } {
     if { [info exists [oo::_classvar $class $varname]] } {
         set [oo::_classvar $class $varname]
     }
}
proc oo::_setup_helper {} {
    set class [lindex [info level -2] 1]
    if { "::__oo_class_helper" ni [info class mixins $class] } {
        uplevel 2 {
            self export varname
            mixin -append __oo_class_helper
        }
    }
    set class
}
oo::class create __oo_class_helper {
    constructor { args } {

        # Initialize the instance variables
        #
        foreach { name value } [oo::_get_classvar [self] __variable] {
            set [namespace current]::$name $value
        }

        # Link the classvars
        #
        foreach var [oo::_get_classvar [self] __classvar] {
            upvar [oo::_classvar [self] $var] [namespace current]::$var
        }

        # Create the linked procs
        #
        foreach link [oo::_get_classvar [self] __linked] {
            proc [namespace current]::$link args [subst { tailcall my $link {*}\$args }]
        }

        catch { next {*}$args }
    }
}

Some testing:

 source tcloo.tcl

 oo::class create clazz {

    public  variable A 1
    private variable B 2
    private variable F 2

    classvar C 3

    public classvar D 4
    private classvar E 5

    public method get { name } {
        set $name
    }

    private proc aproc { name } {
        set $name
    }
    public method tryproc {} {
        aproc B
    }

    constructor { args } {
        set F 10
        set G 11
    }
 } 

 set inst [clazz create instance]

 proc is { A B } {
    if { $A ne $B } {
        puts "Fail \n$A\n$B"
        exit 1
    }
 }
 proc message { script } {
    try {
        uplevel $script
    } on error message { 
        return $message
    }
 }

 is [$inst A] 1
 is [$inst get A] 1 
 is [$inst A 4] 4
 is [$inst A] 4
 is [$inst get B] 2
 is [message { $inst B }] {unknown method "B": must be A, D, destroy, get or tryproc}
 is [$inst get C] 3
 is [$inst get D] 4
 is [$inst D]     4
 is [message { $inst E }] {unknown method "E": must be A, D, destroy, get or tryproc}

 is [$inst get F] 10
 is [$inst tryproc] 2


 puts OK

Category Object Orientation