Version 4 of JBR's tcloo.tcl

Updated 2012-09-14 00:49:54 by RLE
# Declare accessor methods for instance variables
#
proc oo::define::accessor args {
    set currentclass [lindex [info level 1] 1]

    foreach var $args {
        oo::define $currentclass [subst { method $var args { set $var {*}\$args } }]
    }
}
    #oo::class create X {
    #    variable a b c
    #    accessor a b 
    #
    #    constructor {} {
    #             set a 34
    #    }
    #}
    #
    #X create x
    #puts [x a]
    #x a 21
    #puts [x a]


# Control method visibility
#
proc oo::define::public { method name args body } {
    set currentclass [lindex [info level 1] 1]

    oo::define $currentclass [subst { method $name { $args } { $body }; export $name }]
}
proc oo::define::private { method name args body } {
    set currentclass [lindex [info level 1] 1]

    oo::define $currentclass [subst { method $name { $args } { $body }; unexport $name }]
}



# Create procs in the objects namespace that forward calls to class methods.  This
# allows methods to be called without [self] or [my].
#
proc procs args {
    foreach proc $args {
        proc [uplevel 1 { namespace current }]::$proc args [subst { tailcall my $proc {*}\$args }]
    }
}
    #oo::class create X {
    #    constructor {} {
    #        procs a b c 
    #    }
    #
    #    method a {} { b }
    #    method b {} { puts XXX }
    #}
    #
    #X create x
    #x a


proc ::oo::Helpers::classvar { args } {                        # http://wiki.tcl.tk/21595 + mods
    set class [lindex [uplevel 1 {self class}] 0]

    oo::define $class self export varname

    foreach { var value } $args {
        set myvar [uplevel 1 [list my varname $var]]
        set clvar [$class varname $var]

        uplevel 1 [list upvar $clvar $myvar]

        if { ![info exists $clvar] } {
            set $clvar $value
        }
    }
}

AK - 2012-09-13 16:57:59

This might be a candidate for inclusion into http://tcllib.cvs.sourceforge.net/viewvc/tcllib/tcllib/modules/ooutil/