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