1# # ## ### ##### ######## ############# #################### 2## -*- tcl -*- 3## (C) 2011-2015 Andreas Kupries, BSD licensed. 4 5# # ## ### ##### ######## ############# #################### 6## Requisites 7 8package require Tcl 8.5 9package require TclOO 10 11# # ## ### ##### ######## ############# ##################### 12## Public API implementation 13 14# # ## ### ##### ######## ############# #################### 15## Easy callback support. 16## http://wiki.tcl.tk/21595. v20, Donal Fellows 17 18proc ::oo::Helpers::mymethod {method args} { 19 list [uplevel 1 {namespace which my}] $method {*}$args 20} 21 22# # ## ### ##### ######## ############# #################### 23## Class variable support. Use within instance methods. 24## No use in class definitions. 25## http://wiki.tcl.tk/21595. v63, Donal Fellows, tweaked name, comments 26 27proc ::oo::Helpers::classvariable {name args} { 28 # Get a reference to the class's namespace 29 set ns [info object namespace [uplevel 1 {self class}]] 30 31 # Double up the list of variable names 32 set vs [list $name $name] 33 foreach v $args {lappend vs $v $v} 34 35 # Lastly, link the caller's local variables to the class's 36 # variables 37 uplevel 1 [list namespace upvar $ns {*}$vs] 38} 39 40#================================== 41# Demonstration 42#================================== 43# % oo::class create Foo { 44# method bar {z} { 45# classvar x y 46# return [incr x $z],[incr y] 47# } 48# } 49# ::Foo 50# % Foo create a 51# ::a 52# % Foo create b 53# ::b 54# % a bar 2 55# 2,1 56# % a bar 3 57# 5,2 58# % b bar 7 59# 12,3 60# % b bar -1 61# 11,4 62# % a bar 0 63# 11,5 64 65# # ## ### ##### ######## ############# #################### 66## Class method support, with access in derived classes 67## http://wiki.tcl.tk/21595. v63, Donal Fellows 68 69proc ::oo::define::classmethod {name {args ""} {body ""}} { 70 # Create the method on the class if the caller gave arguments and body 71 set argc [llength [info level 0]] 72 if {$argc == 3} { 73 return -code error "wrong # args: should be \"[lindex [info level 0] 0] name ?args body?\"" 74 } 75 76 # Get the name of the current class or class delegate 77 set cls [namespace which [lindex [info level -1] 1]] 78 set d $cls.Delegate 79 if {[info object isa object $d] && [info object isa class $d]} { 80 set cls $d 81 } 82 83 if {$argc == 4} { 84 oo::define $cls method $name $args $body 85 } 86 87 # Make the connection by forwarding 88 uplevel 1 [list forward $name [info object namespace $cls]::my $name] 89} 90 91# Build this *almost* like a class method, but with extra care to avoid nuking 92# the existing method. 93oo::class create oo::class.Delegate { 94 method create {name args} { 95 if {![string match ::* $name]} { 96 set ns [uplevel 1 {namespace current}] 97 if {$ns eq "::"} {set ns ""} 98 set name ${ns}::${name} 99 } 100 if {[string match *.Delegate $name]} { 101 return [next $name {*}$args] 102 } 103 set delegate [oo::class create $name.Delegate] 104 set cls [next $name {*}$args] 105 set superdelegates [list $delegate] 106 foreach c [info class superclass $cls] { 107 set d $c.Delegate 108 if {[info object isa object $d] && [info object isa class $d]} { 109 lappend superdelegates $d 110 } 111 } 112 oo::objdefine $cls mixin {*}$superdelegates 113 return $cls 114 } 115} 116 117oo::define oo::class self mixin oo::class.Delegate 118 119# Demonstrating… 120# ====== 121# oo::class create ActiveRecord { 122# classmethod find args { puts "[self] called with arguments: $args" } 123# } 124# oo::class create Table { 125# superclass ActiveRecord 126# } 127# Table find foo bar 128# ====== 129# which will write this out (I tested it): 130# ======none 131# ::Table called with arguments: foo bar 132# ====== 133 134# # ## ### ##### ######## ############# #################### 135## Singleton Metaclass 136## http://wiki.tcl.tk/21595. v63, Donal Fellows 137 138oo::class create ooutil::singleton { 139 superclass oo::class 140 variable object 141 method create {name args} { 142 if {![info exists object]} { 143 set object [next $name {*}$args] 144 } 145 return $object 146 } 147 method new args { 148 if {![info exists object]} { 149 set object [next {*}$args] 150 } 151 return $object 152 } 153} 154 155# ====== 156# Demonstration 157# ====== 158# % oo::class create example { 159# self mixin singleton 160# method foo {} {self} 161# } 162# ::example 163# % [example new] foo 164# ::oo::Obj22 165# % [example new] foo 166# ::oo::Obj22 167 168# # ## ### ##### ######## ############# #################### 169## Linking instance methods into instance namespace for access without 'my' 170## http://wiki.tcl.tk/27999, AK 171 172proc ::oo::Helpers::link {args} { 173 set ns [uplevel 1 {namespace current}] 174 foreach link $args { 175 if {[llength $link] == 2} { 176 lassign $link src dst 177 } else { 178 lassign $link src 179 set dst $src 180 } 181 interp alias {} ${ns}::$src {} ${ns}::my $dst 182 } 183 return 184} 185 186# # ## ### ##### ######## ############# #################### 187## Ready 188 189package provide oo::util 1.2.2 190