gistfile1.tcl

package require "TclOO"

oo::class create oss::class {
    superclass oo::class

    constructor { args } {
        oo::class create [self].Meta

        next {*}$args

        set superclasses [list "oo::class"]
        foreach class [info class superclasses [self]] {
            if { [info object isa object "${class}.Meta"] && [info object isa class "${class}.Meta"] } {
                lappend superclasses "${class}.Meta"
            }
        }

        oo::define [self].Meta superclass {*}[lreverse $superclasses]
        oo::objdefine [self] class "[self].Meta"
    }
}

proc ::oo::define::classmethod {name {args ""} {body ""}} {
    # Create the method on the class if the caller gave arguments and body
    set argc [llength [info level 0]]
    if {$argc == 3} {
        return -code error "wrong # args: should be \"[lindex [info level 0] 0] name ?args body?\""
    }

    # Get the name of the current class or class delegate
    set cls [namespace which [lindex [info level -1] 1]]
    set d $cls.Meta
    if {[info object isa object $d] && [info object isa class $d]} {
        set cls $d
    }

    if {$argc == 4} {
        oo::define $cls method $name $args $body
    }
}

oss::class create Something {
    classmethod singleton_method {} {
        puts "Defined as a singleton method on [self class], but called on [self]"
    }
}

oss::class create SubSomething {
    superclass Something
}

oss::class create SubSubSomething {
    superclass SubSomething

    classmethod singleton_method {} {
        puts "Defined as a singleton method on [self class], but called on [self]"
    }
}

Something singleton_method
SubSomething singleton_method
SubSubSomething singleton_method