!! Note !!  edit

aspect's tcl-hacks

Overview  edit

  info object isa metaclass ''object''
    This returns whether object is a class that can manufacture classes (i.e. is oo::class or a subclass of it).

• the tests could be more complete in ensuring metaclass methods don't leak, etc
• complete coverage of TclOO Tricks in this safer style -- I think this is now sufficient to cover the reasonable items in there which write on oo::define
• namespace, package and document suitably for inclusion in tcllib, to replace some of the more broken parts of ooutil
• direct readers of TclOO Tricks to this page, possibly deleting some of the content here
• justify calling this package SMOP, though it's not really a Simple Meta-Object Protocol
• add some trivial wrappers of oo::object and oo::class that make life easier and might as well live here

Discussion  edit

https://github.com/ActiveState/stackato-cli

    https://github.com/ActiveState/stackato-cli/blob/master/lib/stackato/v2base.tcl

    https://github.com/ActiveState/stackato-cli/blob/master/lib/stackato/v2domain.tcl

Code  edit

# helper procs which belong in their own package:

    # aka [range].  Args are actually {{x 0} y+1}
    proc iota {a {b ""}} {
        if {$b eq ""} {
            set b $a
            set a 0
        }
        for {set r {}} {$a<$b} {incr a} {
            lappend r $a
        }
        return $r
    }

    # this is generally useful.
    # with multiple arguments it is equivalent to:
    #   [concat {*}[lmap ...]]
    # which under some circumstances can be thought of as:
    #   [join [lmap ...] " "]
    # the pattern comes up a lot.
    # Alternative names:  [lconcat] [ljoin] [lmap*]
    #
    proc lconcat args {
        concat {*}[uplevel 1 lmap $args]
    }

    # normal map, but does multiple arguments:
    #  % map {expr} {1 2 3} {+ - *} {2 4 5}
    #  {3 -2 15}
    #
    proc map {cmdPrefix args} {
        set names [iota [llength $args]]
        set forArgs [lconcat n $names a $args {list $n $a}]
        set cmdArgs [lconcat name $names {string cat \$ $name}]
        set body "$cmdPrefix $cmdArgs"
        set body "uplevel 1 \[list $body\]"
        lmap {*}$forArgs $body
    }

# a metaclass is a place for defining additional "class definition" methods, in addition
# to those normally available via oo::define.
#
oo::class create metaclass {
    superclass oo::class
    constructor {args} {
        if {[info object class [self]] eq [self class]} {
            ;# only if we're defining a metaclass:
            oo::define [self] superclass [self class]
        } else {
            ;# but not if we're defining an instance:
        }

        set myns [self namespace]::ns   ;# namespace for evaluating creation script
                                        ;# to which all our methods are aliased:
        foreach cmd [info object methods [self] -all] {
            if {$cmd ni {new create destroy}} { ;# object and class methods don't count
                interp alias {} ${myns}::$cmd {} [self] $cmd
            }
        }
        tailcall namespace eval $myns {*}$args  ;# in lieu of [next]
        ;#namespace eval $myns {*}$args
        ;#rename ${myns}::self {}
    }
}

;# wrap all the oo::define commands as methods on the class:
foreach cmd [map {namespace tail} [info commands ::oo::define::*]] {
    oo::define metaclass method $cmd args "
        oo::define \[self\] $cmd {*}\$args
    "
}

Class Variables

#   classvariable defines a variable that lives on the class object, and is 
#   linked via [namespace upvar]ed as an object variable into each instance's
#   namespace on creation.
#
# It is the equivalent of:
#   oo::class create Cnted {
#     variable n    ;# makes n visible in methods
#     variable x
#     constructor {} {
#        my eval namespace upvar [info object namespace [self class]] n n
#        incr n
#        set x $n
#     }
#     method who {} {
#        return "I am $n of $x"
#     }
#   }

    metaclass create ClassyVars {
        variable Classvars
        constructor args {
            set Classvars {}
            next {*}$args
            oo::define [self] mixin -append [ClassyVarMixin new $Classvars]
        }
        method classvariable {name} {
            lappend Classvars $name
            uplevel 1 [list variable $name]
        }
    }

# to achieve this we use a "dynamic mixin".  This is just a way to create a mixin with a
# parameter:  in this case, ClassyVarMixin takes a list of (unqualified) variable names
# as a parameter, and creates an instance whose constructor links those variables to the
# class.

;# FIXME: hypnotoad wasn't very keen on this, though he acknowledged it requires less code than his sqlite-backed interps.
;# FIXME: hypnotoad's suggestion:  move the constructor into a common Initialize method
    oo::class create ClassyVarMixin {
        superclass oo::class
        constructor {classvars} {
            set vars [lmap v $classvars {list $v $v}]
            set vars [concat {*}$vars]
            oo::define [self] constructor {args} [format {
                set cls [info object class [self]]  ;# our actual class, for putting the var in
                set cns [info object namespace $cls]
                oo::objdefine $cls variable %2$s
                my eval namespace upvar $cns %1$s
                next {*}$args
            } $vars $classvars]
        }
    }

Test

tcltest::test classvariable-1.1 "Basic classvariable test" -body {
    ClassyVars create Counted {
        classvariable n
        variable x
        constructor args {
            set x [incr n]
            # note: no [next]!
        }
        method who {} {
            list $x of $n
        }
        destructor {
            incr n -1
        }
    }
    concat [lmap o {a b c} {
        Counted create $o
        $o who
    }] [lmap o {a b c} {
        $o who
    }] [lmap o {a b c} {
        apply {{x args} {set x}} [$o who] [$o destroy]
    }] [rename Counted {}]
} -result {{1 of 1} {2 of 2} {3 of 3} {1 of 3} {2 of 3} {3 of 3} {1 of 3} {2 of 2} {3 of 1}}

Class Methods

# a classmethod (Ruby-like version) is a method that can be called on a class,
# and on subclasses of that class, but not on their instances
#
# The simplest way to put a method on a class is like this:
#  oo::class create Foo {
#    self method bar {} {}
#  }
#
# Or:
#  oo::class create Foo {}
#  oo::objdefine Foo bar {} {}
#
# Both of which permit:
#  Foo bar
#
# But to get on the superclass inheritance chain, it needs to be a class method on Foo's class.
# We fake this by creating a paralell inheritance hierarchy of metaclasses, which is easier to
# explain in code:

    metaclass create ClassyMethods {
        variable Classmethods
        constructor args {
            uplevel 1 [format {
                oo::class create %1$s.Class {
                    superclass oo::class
                }
            } [list [self]]]
            next {*}$args
            oo::objdefine [self] class [self].Class
        }
        method classmethod {name args body} {
            tailcall oo::define [self].Class method $name $args $body
        }
        method superclass {class} {
            #debug do oo::objdefine [self] mixin -append $class
            tailcall oo::define [self].Class superclass ${class}.Class
        }
    }

Test

tcltest::test classmethod-1.1 "Basic classmethod test" -body {
    ;# we want to start with this definition:
    ClassyMethods create ActiveRecord {
        classmethod find args {
            list [self] finding {*}$args
        }
    }

    ClassyMethods create Table {
        superclass ActiveRecord
    }

    ClassyMethods create ConcreteTable {
        superclass Table
    }

    list [Table find] [ConcreteTable find]
} -result {{::Table finding} {::ConcreteTable finding}}

# the above definition expands to something like the following:
#  ClassyMethods create ActiveRecord.Class {
#      method find args {
#          list [self] finding {*}$args
#      }
#  }
#  ClassyMethods create ActiveRecord {
#      class ActiveRecord.Class
#  }
#  
#  ClassyMethods create Table.Class {
#      superclass ActiveRecord
#  }
#  ClassyMethods create Table {
#      superclass Table.Class
#  }

Private Methods

# This one is pretty simple.

metaclass create PrivacyConcious {
    method private {method name args} {
        ;# FIXME: this is not robust against other things we might want to make private, like forwards?
        if {$method ne "method"} {return -code error "must be: private method <name> <args> <body>"}
        uplevel 1 [list $method $name {*}$args]
        uplevel 1 [list unexport $name]
    }
}

Test

tcltest::test privatemethod-1.1 "Basic private method test" -body {
    PrivacyConcious create Pc {
        private method foo {} {
            list [self class] [self object]
        }
        method bar {} {
            my foo
        }
    }
    Pc create pc

    list [pc bar] [catch {
        pc foo
    } e o] $e [dict get $o -errorcode]
} -result {{::Pc ::pc} 1 {unknown method "foo": must be bar or destroy} {TCL LOOKUP METHOD foo}}

Abstract Methods

## Doesn't work!
    oo::class create AbstractMixin {
        superclass oo::class
        constructor {abstractmethods} {
            oo::define [self] constructor {args} [format {
debug log {Consing AbstractMixinstance [self] [self class] [info object class [self]]}
                next   {*}$args
                set mymethods [info class methods [self] -all]
                foreach m %1$s {
                    if {$m ni $mymethods} {
                        throw {CLASS ABSTRACTMETHOD} "abstract method $m not provided in [self]!"
                    }
                }
            } [list $abstractmethods]]
        }
    }

    metaclass create AbstractBase {
        variable Abstractmethods
        constructor args {
            set Abstractmethods {}
            next {*}$args
            oo::define [self] mixin -append [AbstractMixin new $Abstractmethods]
        }
        method abstractmethod {name} {
            lappend Abstractmethods $name
        }
    }

Test

## Doesn't work!
tcltest::test abstractmethod-1.1 "Basic abstractmethod test" -body {
    # things that look like read/write channels:
    AbstractBase create Channish {
        constructor args {
            puts "Making a Channish called [self]"
            #next   {*}$args
        }
        abstractmethod read
        abstractmethod write
        # method, constructor, etc
    }

    Channish create Try {
        method read {args} {}
        method write {} {}
    }

    list [catch {
        Channish create Try2 {
            method read {args} {}
        }
    } e o] $e [dict get $o -errorcode]
} -result {1 {abstract method write not provided in ::Try2!} {CLASS ABSTRACTMETHOD}}

Mixing it Up

tcltest::test smop-mixin-1.1 "Testing mixin composition" -body {
    metaclass create Class {
        mixin -append ClassyVars PrivacyConcious ClassyMethods
    }

    Class create Wop {
        classvariable n
        variable x
        constructor args {
            set x [incr n]
        }
        method who {} {
            list $x of $n
        }
        private method woo {} {}
        classmethod what {} {
            variable n  ;# because classvariable knows not of classmethod, and v-v
                        ;# and classmethods actually live on class.Class
            list we be $n
        }
    }
    Wop create who
    Wop create woo
    list [who who] [woo who] [Wop what]
} -result {{1 of 2} {2 of 2} {we be 2}}

Abstract Class edit

oo::class create ::class {
    superclass oo::class
    self method create {name args} {
        set instance [next $name {*}$args]
        oo::define $instance superclass -append [self]
        return $instance
    }
    method new args {
        my <VERIFY.CONCRETE>
        next {*}$args
    }
    method create {name args} {
        my <VERIFY.CONCRETE>
        next $name {*}$args
    }

    method <VERIFY.CONCRETE> {} {
        foreach m [info class methods [self] -all] {
            set call [lindex [info class call [self] $m] 0]
            if {[lindex $call 0] eq "method" && [lindex $call 3] eq "method"} {
                set cls [lindex $call 2]
                set body [lindex [info class definition $cls $m] 1]
                if {$body eq "abstract"} {
                    return -code error -level 2 \
                        -errorcode {CLASS ABSTRACTMETHOD} \
                        "[self] is abstract (method \"$m\")"
                }
            }
        }
    }
}

    method foobar {x y args} abstract

package require tcltest

tcltest::test abstractmethod-1.1 "Basic abstractmethod test" -body {
    # things that look like read/write channels:
    class create Channish {
        constructor args {
            puts "Making a Channish called [self]"
            #next   {*}$args
        }
        method read args abstract
        method write {} abstract
        # method, constructor, etc
    }

    class create Try {
        superclass Channish
        method read {args} {}
        method write {} {}
    }

    list [catch {
        Try new
        Channish new
    } e o] $e [dict get $o -errorcode]
} -result {1 {::Channish is abstract (method "read")} {CLASS ABSTRACTMETHOD}}

tcltest::cleanupTests

Garbage Collection (sort of) edit

gc_class

oo::class create ::gc_class {
    superclass ::oo::class

    method instvar {varname args} {
        upvar 1 $varname scopevar
        if {[array exists scopevar]} {
            error "Can't use $varname for the instance variable: it exists and is an array"
        }
        # Chain to [new] using an uplevel to preserve the relative callframe context vs [new] and [create]
        set scopevar [uplevel 1 [list [namespace origin my] new {*}$args]]
        set fqobj [namespace origin $scopevar] 
        trace add variable scopevar {write unset} [list [namespace origin my] _gc $fqobj]
        return ""
    }

    method _gc {fqobj name1 name2 op} { 
        upvar 1 $name1 scopevar
        if {[info object isa object $fqobj]} { $fqobj destroy }
        trace remove variable scopevar {write unset} [list [namespace origin my] _gc $fqobj]
    }

    # Uncomment this to prevent the [new] and [create] methods
    #unexport create new
}

gc_class create Foo {
    variable thing

    constructor {a_thing} {
        set thing   $a_thing
    }

    method greet {} {
        puts "hello, $thing"
    }
}

proc bar {} {
    Foo instvar foo1 "first example"
    $foo1 greet     ;# says "hello, first example"

    Foo instvar foo2 "second example"
    $foo2 greet     ;# says "hello, second example"

    Foo instvar foo2 "third example"    ;# second example dies here
    $foo2 greet     ;# says "hello, third example"

    Foo instvar foo4 "fourth example"
    $foo4 greet     ;# says "hello, fourth example"

    set foo2    "something else"    ;# third example dies here

    unset foo4      ;# fourth example dies here

    Foo instvar ::foo5 "fifth example"

    # first example dies when the proc returns here (since $foo1 goes out of scope)
}

bar

# One Foo instance remains, the "fifth example"

$foo5 greet     ;# says "hello, fifth example"
unset foo5      ;# fifth example dies here

# No instances of Foo remain

proc oo::objdefine::proc {name arguments body} {
    # This is the magical bit
    set obj [uplevel 1 {
        self
    }]
    set ns [info object namespace $obj]
    tailcall ::proc ${ns}::$name $arguments $body
}

oo::class create Foo {
    self {
        proc hi {} {
            puts "hi there from Foo"
        }
        method boo {} {
            puts "start of boo"
            hi
            puts "end of boo"
        }
    }
}

Foo boo

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