line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
1
|
|
|
1
|
|
69103
|
use 5.008008; |
|
1
|
|
|
|
|
4
|
|
2
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
22
|
|
3
|
1
|
|
|
1
|
|
7
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
84
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Sub::SymMethod; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:TOBYINK'; |
8
|
|
|
|
|
|
|
our $VERSION = '0.005'; |
9
|
|
|
|
|
|
|
|
10
|
1
|
|
|
1
|
|
498
|
use Exporter::Shiny our @EXPORT = qw( symmethod ); |
|
1
|
|
|
|
|
4194
|
|
|
1
|
|
|
|
|
7
|
|
11
|
1
|
|
|
1
|
|
62
|
use Scalar::Util qw( blessed ); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
48
|
|
12
|
1
|
|
|
1
|
|
491
|
use Role::Hooks; |
|
1
|
|
|
|
|
4746
|
|
|
1
|
|
|
|
|
103
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
BEGIN { |
15
|
1
|
|
|
|
|
9
|
eval { require mro } |
16
|
1
|
50
|
|
1
|
|
10
|
or do { require MRO::Compat }; |
|
0
|
|
|
|
|
0
|
|
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
eval { |
19
|
1
|
|
|
|
|
598
|
require Types::Standard; |
20
|
1
|
|
|
|
|
99713
|
'Types::Standard'->import(qw/ is_CodeRef is_HashRef /); |
21
|
1
|
|
|
|
|
964
|
1; |
22
|
|
|
|
|
|
|
} |
23
|
1
|
50
|
|
|
|
2
|
or do { |
24
|
1
|
|
|
1
|
|
8
|
*is_CodeRef = sub { no warnings; ref($_[0]) eq 'CODE' }; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
64
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
25
|
1
|
|
|
1
|
|
6
|
*is_HashRef = sub { no warnings; ref($_[0]) eq 'HASH' }; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
50
|
|
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
26
|
|
|
|
|
|
|
}; |
27
|
|
|
|
|
|
|
|
28
|
1
|
|
|
1
|
|
6
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
61
|
|
29
|
1
|
|
|
|
|
7
|
eval { require Sub::Util; 'Sub::Util'->import('set_subname'); 1 } |
|
1
|
|
|
|
|
54
|
|
|
1
|
|
|
|
|
516
|
|
30
|
1
|
50
|
|
|
|
3
|
or do { require Sub::Name; *set_subname = \&Sub::Name::subname; } |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
31
|
|
|
|
|
|
|
}; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
{ |
34
|
|
|
|
|
|
|
# %SPECS is a hash of hashrefs keyed on {package}->{subname}. |
35
|
|
|
|
|
|
|
# The values are specs (themselves hashrefs!) |
36
|
|
|
|
|
|
|
my %SPECS; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub get_symmethods { |
39
|
12
|
|
|
12
|
1
|
23
|
my ( $class, $target, $name ) = ( shift, @_ ); |
40
|
12
|
|
100
|
|
|
51
|
$SPECS{$target}{$name} ||= []; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub get_symmethod_names { |
44
|
6
|
|
|
6
|
1
|
12
|
my ( $class, $target ) = ( shift, @_ ); |
45
|
6
|
|
50
|
|
|
10
|
keys %{ $SPECS{$target} ||= {} }; |
|
6
|
|
|
|
|
24
|
|
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub install_symmethod { |
50
|
7
|
|
|
7
|
1
|
20
|
my ( $class, $target, $name, %args ) = ( shift, @_ ); |
51
|
7
|
50
|
|
|
|
21
|
$args{origin} = $target unless exists $args{origin}; |
52
|
7
|
50
|
|
|
|
46
|
$args{method} = 1 unless exists $args{method}; |
53
|
7
|
|
|
|
|
20
|
$args{name} = $name; |
54
|
7
|
100
|
|
|
|
17
|
$args{order} = 0 unless exists $args{order}; |
55
|
|
|
|
|
|
|
|
56
|
7
|
50
|
|
|
|
25
|
if ( not is_CodeRef $args{code} ) { |
57
|
0
|
|
|
|
|
0
|
require Carp; |
58
|
0
|
|
|
|
|
0
|
Carp::croak('Cannot install symmethod with no valid code; stopped'); |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
|
61
|
7
|
|
|
|
|
20
|
my $symmethods = $class->get_symmethods( $target, $name ); |
62
|
7
|
|
|
|
|
16
|
push @$symmethods, \%args; |
63
|
7
|
|
|
|
|
20
|
$class->clear_cache($name); |
64
|
|
|
|
|
|
|
|
65
|
7
|
100
|
|
|
|
23
|
my $kind = 'Role::Hooks'->is_role($target) ? 'role' : 'class'; |
66
|
|
|
|
|
|
|
|
67
|
7
|
100
|
66
|
|
|
154
|
if ( $kind eq 'class' and not $args{no_dispatcher} ) { |
68
|
4
|
|
|
|
|
12
|
$class->install_dispatcher( $target, $name ); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
|
71
|
7
|
100
|
66
|
|
|
26
|
if ( $kind eq 'role' and not $args{no_hook} ) { |
72
|
3
|
|
|
|
|
8
|
$class->install_hooks( $target ); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
7
|
|
|
|
|
13
|
return $class; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
{ |
80
|
|
|
|
|
|
|
my %KNOWN; |
81
|
|
|
|
|
|
|
sub is_dispatcher { |
82
|
6
|
|
|
6
|
1
|
13
|
my ( $class, $coderef, $set ) = ( shift, @_ ); |
83
|
6
|
100
|
|
|
|
13
|
if ( @_ == 2 ) { |
84
|
1
|
|
|
|
|
4
|
$KNOWN{"$coderef"} = $set; |
85
|
|
|
|
|
|
|
} |
86
|
6
|
|
|
|
|
26
|
$KNOWN{"$coderef"}; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub install_dispatcher { |
91
|
6
|
|
|
6
|
0
|
12
|
my ( $class, $target, $name ) = ( shift, @_ ); |
92
|
|
|
|
|
|
|
|
93
|
6
|
100
|
|
|
|
53
|
if ( my $existing = $target->can($name) ) { |
94
|
5
|
50
|
|
|
|
28
|
return if $class->is_dispatcher( $existing ); |
95
|
0
|
|
|
|
|
0
|
require Carp; |
96
|
0
|
|
|
|
|
0
|
Carp::carp("Symmethod $name overriding existing method for class $target"); |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
1
|
50
|
33
|
|
|
9
|
if ( $name eq 'BUILD' or $name eq 'DEMOLISH' or $name eq 'new' ) { |
|
|
|
33
|
|
|
|
|
100
|
0
|
|
|
|
|
0
|
require Carp; |
101
|
0
|
|
|
|
|
0
|
Carp::carp("Symmethod $name should probably be a plain method"); |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
|
104
|
1
|
|
|
|
|
5
|
my $coderef = $class->build_dispatcher( $target, $name ); |
105
|
1
|
|
|
|
|
4
|
my $qname = "$target\::$name"; |
106
|
|
|
|
|
|
|
|
107
|
1
|
|
|
|
|
2
|
do { |
108
|
1
|
|
|
1
|
|
11
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
40
|
|
109
|
1
|
|
|
1
|
|
10
|
no warnings 'redefine'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
623
|
|
110
|
1
|
|
|
|
|
15
|
*$qname = set_subname( $qname, $coderef ); |
111
|
|
|
|
|
|
|
}; |
112
|
|
|
|
|
|
|
|
113
|
1
|
|
|
|
|
5
|
$class->is_dispatcher( $coderef, $qname ); |
114
|
|
|
|
|
|
|
|
115
|
1
|
|
|
|
|
2
|
return $class; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
sub build_dispatcher { |
119
|
2
|
|
|
2
|
1
|
7
|
my ( $class, $target, $name ) = ( shift, @_ ); |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
return sub { |
122
|
3
|
|
|
3
|
|
19
|
my $specs = $class->get_all_symmethods( $_[0], $name ); |
|
|
|
|
3
|
|
|
|
123
|
3
|
|
|
|
|
7
|
my @results; |
124
|
3
|
|
|
|
|
7
|
SPEC: for my $spec ( @$specs ) { |
125
|
21
|
100
|
|
|
|
7965
|
if ( $spec->{signature} ) { |
126
|
3
|
100
|
|
|
|
15
|
$class->compile_signature($spec) unless is_CodeRef $spec->{signature}; |
127
|
3
|
|
|
|
|
9
|
my @orig = @_; |
128
|
3
|
|
|
|
|
10
|
my @inv = splice( @orig, 0, $spec->{method} ); |
129
|
3
|
|
|
|
|
5
|
my @new; |
130
|
|
|
|
|
|
|
{ |
131
|
3
|
|
|
|
|
6
|
local $@; |
|
3
|
|
|
|
|
5
|
|
132
|
3
|
100
|
|
|
|
6
|
eval{ @new = $spec->{signature}(@orig); 1 } |
|
3
|
|
|
|
|
12
|
|
|
2
|
|
|
|
|
62
|
|
133
|
|
|
|
|
|
|
or next SPEC; |
134
|
|
|
|
|
|
|
} |
135
|
2
|
|
|
|
|
10
|
push @results, scalar $spec->{code}( @inv, @new ); |
136
|
2
|
|
|
|
|
31
|
next SPEC; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
18
|
|
|
|
|
46
|
push @results, scalar $spec->{code}( @_ ); |
140
|
|
|
|
|
|
|
} |
141
|
3
|
|
|
|
|
33
|
return @results; |
142
|
2
|
|
|
|
|
15
|
}; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub dispatch { |
146
|
1
|
|
|
1
|
1
|
6
|
my ( $class, $invocant, $name ) = ( shift, shift, shift, @_ ); |
147
|
1
|
|
33
|
|
|
8
|
my $invocant_class = blessed($invocant) || $invocant; |
148
|
|
|
|
|
|
|
|
149
|
1
|
|
|
|
|
5
|
my $dispatcher = $class->build_dispatcher( $invocant_class, $name ); |
150
|
1
|
|
|
|
|
4
|
unshift @_, $invocant; |
151
|
1
|
|
|
|
|
4
|
goto $dispatcher; |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
{ |
155
|
|
|
|
|
|
|
my %HOOKED; |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub install_hooks { |
158
|
3
|
|
|
3
|
1
|
7
|
my ( $class, $target ) = ( shift, @_ ); |
159
|
|
|
|
|
|
|
|
160
|
3
|
100
|
|
|
|
10
|
return if $HOOKED{$target}++; |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
'Role::Hooks'->before_apply( $target, sub { |
163
|
4
|
|
|
4
|
|
392
|
my ( $role, $consumer ) = @_; |
164
|
|
|
|
|
|
|
|
165
|
4
|
100
|
|
|
|
11
|
if ( not 'Role::Hooks'->is_role($consumer) ) { |
166
|
2
|
|
|
|
|
37
|
push @{ $class->get_roles_for_class($consumer) }, $target; |
|
2
|
|
|
|
|
5
|
|
167
|
|
|
|
|
|
|
|
168
|
2
|
|
|
|
|
5
|
for my $name ( $class->get_symmethod_names($target) ) { |
169
|
2
|
|
|
|
|
4
|
$class->install_dispatcher( $consumer, $name ); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
4
|
|
|
|
|
38
|
$class->clear_cache( $class->get_symmethod_names($target) ); |
174
|
2
|
|
|
|
|
16
|
} ); |
175
|
|
|
|
|
|
|
|
176
|
2
|
|
|
|
|
513
|
return $class; |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
{ |
181
|
|
|
|
|
|
|
# %ROLES is a hash keyed on {classname} where the values |
182
|
|
|
|
|
|
|
# are an arrayref of rolenames of roles the class is known to consume. |
183
|
|
|
|
|
|
|
# We only care about roles which define symmethods. |
184
|
|
|
|
|
|
|
my %ROLES; |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub get_roles_for_class { |
187
|
5
|
|
|
5
|
1
|
10
|
my ( $class, $target ) = ( shift, @_ ); |
188
|
5
|
|
100
|
|
|
23
|
$ROLES{$target} ||= []; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
{ |
193
|
|
|
|
|
|
|
# %CACHE is a hash of hashrefs keyed on {subname}->{invocantclass} |
194
|
|
|
|
|
|
|
# to avoid needing to crawl MRO for each method call. |
195
|
|
|
|
|
|
|
# The values are arrayrefs of specs |
196
|
|
|
|
|
|
|
my %CACHE; |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
sub clear_cache { |
199
|
11
|
|
|
11
|
1
|
19
|
my ( $class ) = ( shift ); |
200
|
11
|
|
|
|
|
25
|
delete $CACHE{$_} for @_; |
201
|
11
|
|
|
|
|
21
|
return $class; |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub get_all_symmethods { |
205
|
3
|
|
|
3
|
1
|
10
|
my ( $class, $invocant, $name ) = ( shift, @_ ); |
206
|
3
|
|
33
|
|
|
19
|
my $invocant_class = blessed($invocant) || $invocant; |
207
|
|
|
|
|
|
|
|
208
|
3
|
100
|
|
|
|
11
|
if ( not $CACHE{$name}{$invocant_class} ) { |
209
|
1
|
|
|
1
|
|
694
|
use sort 'stable'; |
|
1
|
|
|
|
|
561
|
|
|
1
|
|
|
|
|
6
|
|
210
|
|
|
|
|
|
|
$CACHE{$name}{$invocant_class} = [ |
211
|
12
|
|
|
|
|
21
|
sort { $a->{order} <=> $b->{order} } |
212
|
5
|
|
|
|
|
10
|
map @{ $class->get_symmethods( $_, $name ) }, |
213
|
3
|
|
|
|
|
7
|
map +( @{ $class->get_roles_for_class($_) }, $_ ), |
214
|
1
|
50
|
|
|
|
2
|
reverse @{ mro::get_linear_isa( $invocant_class ) || [] } |
|
1
|
|
|
|
|
8
|
|
215
|
|
|
|
|
|
|
]; |
216
|
1
|
|
|
|
|
5
|
Internals::SvREADONLY($CACHE{$name}{$invocant_class}, 1); |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
3
|
|
|
|
|
9
|
$CACHE{$name}{$invocant_class}; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
sub compile_signature { |
224
|
1
|
|
|
1
|
1
|
663
|
require Type::Params; |
225
|
1
|
|
|
|
|
15896
|
my ( $class, $spec ) = ( shift, @_ ); |
226
|
|
|
|
|
|
|
|
227
|
1
|
|
|
|
|
2
|
my @sig = @{ delete $spec->{signature} }; |
|
1
|
|
|
|
|
5
|
|
228
|
1
|
50
|
|
|
|
8
|
my %opt = is_HashRef($sig[0]) ? %{ shift @sig } : (); |
|
0
|
|
|
|
|
0
|
|
229
|
|
|
|
|
|
|
|
230
|
1
|
|
33
|
|
|
18
|
$opt{subname} ||= sprintf( '%s::%s', $spec->{origin}, $spec->{name} ); |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
$spec->{signature} = $spec->{named} |
233
|
1
|
50
|
|
|
|
15
|
? Type::Params::compile_named_oo( \%opt, @sig ) |
234
|
|
|
|
|
|
|
: Type::Params::compile( \%opt, @sig ); |
235
|
|
|
|
|
|
|
|
236
|
1
|
|
|
|
|
4569
|
return $class; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub _generate_symmethod { |
240
|
5
|
|
|
5
|
|
13662
|
my ( $class, undef, undef, $globals ) = ( shift, @_ ); |
241
|
|
|
|
|
|
|
|
242
|
5
|
|
|
|
|
13
|
my $target = $globals->{into}; |
243
|
5
|
50
|
|
|
|
13
|
ref($target) and die 'Cannot export to non-package'; |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
return sub { |
246
|
7
|
100
|
|
7
|
|
1564
|
splice(@_, -1, 0, 'code') unless @_ % 2; |
247
|
7
|
|
|
|
|
23
|
my ( $name, %args ) = @_; |
248
|
7
|
|
|
|
|
37
|
$class->install_symmethod( $target, $name, %args ); |
249
|
7
|
|
|
|
|
26
|
return; |
250
|
5
|
|
|
|
|
54
|
}; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
1; |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
__END__ |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=pod |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=encoding utf-8 |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
=head1 NAME |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
Sub::SymMethod - symbiotic methods; methods that act a little like BUILD and DEMOLISH |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
=head1 SYNOPSIS |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
use strict; |
268
|
|
|
|
|
|
|
use warnings; |
269
|
|
|
|
|
|
|
use feature 'say'; |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
{ |
272
|
|
|
|
|
|
|
package Local::Base; |
273
|
|
|
|
|
|
|
use Class::Tiny; |
274
|
|
|
|
|
|
|
use Sub::SymMethod; |
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
symmethod foo => sub { say __PACKAGE__ }; |
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
{ |
280
|
|
|
|
|
|
|
package Local::Role; |
281
|
|
|
|
|
|
|
use Role::Tiny; |
282
|
|
|
|
|
|
|
use Sub::SymMethod; |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
symmethod foo => sub { say __PACKAGE__ }; |
285
|
|
|
|
|
|
|
} |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
{ |
288
|
|
|
|
|
|
|
package Local::Derived; |
289
|
|
|
|
|
|
|
use parent -norequire, 'Local::Base'; |
290
|
|
|
|
|
|
|
use Role::Tiny::With; with 'Local::Role'; |
291
|
|
|
|
|
|
|
use Sub::SymMethod; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
symmethod foo => sub { say __PACKAGE__ }; |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
'Local::Derived'->foo(); |
297
|
|
|
|
|
|
|
# Local::Base |
298
|
|
|
|
|
|
|
# Local::Role |
299
|
|
|
|
|
|
|
# Local::Derived |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
=head1 DESCRIPTION |
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
Sub::SymMethod creates hierarchies of methods so that when you call one, |
304
|
|
|
|
|
|
|
all the methods in the inheritance chain (including ones defined in roles) |
305
|
|
|
|
|
|
|
are invoked. |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
They are invoked from the most basal class to the most derived class. |
308
|
|
|
|
|
|
|
Methods defined in roles are invoked before methods defined in the class |
309
|
|
|
|
|
|
|
they were composed into. |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
This is similar to how the C<BUILD> and C<DEMOLISH> methods are invoked |
312
|
|
|
|
|
|
|
in L<Moo>, L<Moose>, and L<Mouse>. (You should I<not> use this module to |
313
|
|
|
|
|
|
|
define C<BUILD> and C<DEMOLISH> methods though, as Moo/Moose/Mouse already |
314
|
|
|
|
|
|
|
includes all the plumbing to ensure that they are called correctly. This |
315
|
|
|
|
|
|
|
module is instead intended to allow you to define your own methods which |
316
|
|
|
|
|
|
|
behave similarly.) |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
You can think of "symmethod" as being short for "symbiotic method", |
319
|
|
|
|
|
|
|
"syncretic method", or "synarchy of methods". |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
If you are familiar with L<multi methods|Sub::MultiMethod>, you can think |
322
|
|
|
|
|
|
|
of a symmethod as a multi method where instead of picking one "winning" |
323
|
|
|
|
|
|
|
candidate to dispatch to, the dispatcher dispatches to as many candidates |
324
|
|
|
|
|
|
|
as it can find! |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
=head2 Use Cases |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
Symmethods are useful for "hooks". For example, the following pseudocode: |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
class Message { |
331
|
|
|
|
|
|
|
method send () { |
332
|
|
|
|
|
|
|
$self->on_send(); |
333
|
|
|
|
|
|
|
$self->do_smtp_stuff(); |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
symmethod on_send () { |
337
|
|
|
|
|
|
|
# do nothing |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
|
|
|
|
|
|
role LoggedMessage { |
342
|
|
|
|
|
|
|
symmethod on_send () { |
343
|
|
|
|
|
|
|
print STDERR "Sending message\n"; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
class ImportantMessage { |
348
|
|
|
|
|
|
|
extends Message; |
349
|
|
|
|
|
|
|
with LoggedMessage; |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
symmethod on_send () { |
352
|
|
|
|
|
|
|
$self->add_to_archive( "Important" ); |
353
|
|
|
|
|
|
|
} |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
When the C<send> method gets called on an ImportantMessage object, the |
357
|
|
|
|
|
|
|
inherited C<send> method from Message will get invoked. This will call |
358
|
|
|
|
|
|
|
C<on_send>, which will call every C<on_send> definition in the inheritance |
359
|
|
|
|
|
|
|
hierarchy for ImportantMessage, ensuring the sending of the important |
360
|
|
|
|
|
|
|
message gets logged to STDERR and the message gets archived. |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
=head2 Functions |
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
Sub::SymMethod exports one function, but which may be called in two |
365
|
|
|
|
|
|
|
different ways. |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
=over |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
=item C<< symmethod $name => $coderef >> |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
Creates a symmethod. |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
=item C<< symmethod $name => %spec >> |
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
Creates a symmethod. |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
The specification hash must contain a C<code> key, and may contain |
378
|
|
|
|
|
|
|
C<signature>, C<named>, and C<method> keys, which work the same as in |
379
|
|
|
|
|
|
|
L<Sub::MultiMethod>. It may also include an C<order> key. |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=back |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
=head2 Invoking Symmethods |
384
|
|
|
|
|
|
|
|
385
|
|
|
|
|
|
|
Given the following pseudocode: |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
class Base { |
388
|
|
|
|
|
|
|
symmethod foo () { |
389
|
|
|
|
|
|
|
say wantarray ? "List context" : "Scalar context"; |
390
|
|
|
|
|
|
|
return "BASE"; |
391
|
|
|
|
|
|
|
} |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
class Derived { |
395
|
|
|
|
|
|
|
extends Base; |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
symmethod foo () { |
398
|
|
|
|
|
|
|
say wantarray ? "List context" : "Scalar context"; |
399
|
|
|
|
|
|
|
return "DERIVED"; |
400
|
|
|
|
|
|
|
} |
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
my @r = Derived->foo(); |
404
|
|
|
|
|
|
|
my $r = Derived->foo(); |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
"Scalar context" will be said four times. Symmethods are always invoked in |
407
|
|
|
|
|
|
|
scalar context even when they have been called in list context! |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
The C<< @r >> array will be C<< ( "BASE", "DERIVED" ) >>. When a symmethod |
410
|
|
|
|
|
|
|
is called in list context, a list of the returned values will be returned. |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
The variable C<< $r >> will be C<< 2 >>. It is the count of the returned |
413
|
|
|
|
|
|
|
values. |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
If a symmethod throws an exception this will not be caught, so any further |
416
|
|
|
|
|
|
|
symmethods waiting to be invoked will not get invoked. |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=head3 Invocation Order |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
It is possible to force a symmethod to run early by setting C<order> to |
421
|
|
|
|
|
|
|
a negative number. |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
symmethod foo => ( |
424
|
|
|
|
|
|
|
order => -100, |
425
|
|
|
|
|
|
|
code => sub { my $self = shift; ... }, |
426
|
|
|
|
|
|
|
); |
427
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
It is possible to force a symmethod to run late by setting order to a |
429
|
|
|
|
|
|
|
positive number. |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
symmethod foo => ( |
432
|
|
|
|
|
|
|
order => 100, |
433
|
|
|
|
|
|
|
code => sub { my $self = shift; ... }, |
434
|
|
|
|
|
|
|
); |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
The default C<order> is 0 for all symmethods, and in most cases this will |
437
|
|
|
|
|
|
|
be fine. |
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
Where symmethods have the same order (the usual case!) symmethods are invoked |
440
|
|
|
|
|
|
|
from most basal class to most derived class -- i.e. from parent to child. |
441
|
|
|
|
|
|
|
Where a class consumes symmethods from roles, a symmethods defined in a role |
442
|
|
|
|
|
|
|
will be invoked before a symmethod defined in the class, but after any |
443
|
|
|
|
|
|
|
inherited from base/parent classes. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=head2 Symmethods and Signatures |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
When defining symmethods, you can define a signature: |
448
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
use Types::Standard 'Num'; |
450
|
|
|
|
|
|
|
use Sub::SymMethod; |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
symmethod foo => ( |
453
|
|
|
|
|
|
|
signature => [ Num ], |
454
|
|
|
|
|
|
|
code => sub { |
455
|
|
|
|
|
|
|
my ( $self, $num ) = @_; |
456
|
|
|
|
|
|
|
print $num, "\n"; |
457
|
|
|
|
|
|
|
}, |
458
|
|
|
|
|
|
|
); |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
symmethod foo => ( |
461
|
|
|
|
|
|
|
named => 1, |
462
|
|
|
|
|
|
|
signature => [ mynum => Num ], |
463
|
|
|
|
|
|
|
code => sub { |
464
|
|
|
|
|
|
|
my ( $self, $arg ) = @_; |
465
|
|
|
|
|
|
|
print $arg->mynum, "\n"; |
466
|
|
|
|
|
|
|
}, |
467
|
|
|
|
|
|
|
); |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
When the symmethod is called, any symmethods where the arguments do not match |
470
|
|
|
|
|
|
|
the signature are simply skipped. |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
The invocant ($self or $class or whatever) is I<not> included in the |
473
|
|
|
|
|
|
|
signature. |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
The coderef given in C<code> receives the list of arguments I<after> they've |
476
|
|
|
|
|
|
|
been passed through the signature, which may coerce them, etc. |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
Instead of an arrayref (which will be treated as a signature using |
479
|
|
|
|
|
|
|
L<Type::Params> C<compile> or C<compile_named_oo>), you can provide a |
480
|
|
|
|
|
|
|
signature as a coderef. The coderef will be passed a list of argument to |
481
|
|
|
|
|
|
|
the symmethod to be checked. If the arguments are bad, it should throw an |
482
|
|
|
|
|
|
|
exception (which will be caught, and the symmethod will be safely skipped). |
483
|
|
|
|
|
|
|
If the arguments are good, it should return the list of arguments, possibly |
484
|
|
|
|
|
|
|
after some coercion or other processing. |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
Using an arrayref signature requires L<Type::Params> to be installed. |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
=head2 API |
489
|
|
|
|
|
|
|
|
490
|
|
|
|
|
|
|
Sub::SymMethod has an object oriented API for metaprogramming. |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
When describing it, we'll borrow the terms I<dispatcher> and I<candidate> |
493
|
|
|
|
|
|
|
from L<Sub::MultiMethod>. The candidates are the coderefs you gave to |
494
|
|
|
|
|
|
|
Sub::SymMethod -- so there might be a candidate defined in your parent |
495
|
|
|
|
|
|
|
class and a candidate defined in your child class. The dispatcher is the |
496
|
|
|
|
|
|
|
method that Sub::SymMethod creates for you (probably just in the base |
497
|
|
|
|
|
|
|
class, but theoretically perhaps also in the child class) which is responsible |
498
|
|
|
|
|
|
|
for finding the candidates and calling them. |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
The Sub::SymMethod API offers the following methods: |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
=over |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
=item C<< install_symmethod( $target, $name, %spec ) >> |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
Installs a candidate method for a class or role. |
507
|
|
|
|
|
|
|
|
508
|
|
|
|
|
|
|
C<< $target >> is the class or role the candidate is being defined for. |
509
|
|
|
|
|
|
|
C<< $name >> is the name of the method. C<< %spec >> must include a |
510
|
|
|
|
|
|
|
C<code> key and optionally C<named>, C<signature>, C<method>, and |
511
|
|
|
|
|
|
|
C<order> keys. |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
If C<< $target >> is a class, this will also install a dispatcher into |
514
|
|
|
|
|
|
|
the class. Passing C<< no_dispatcher => 1 >> in the spec will avoid this. |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
If C<< $target >> is a role, this will also install hooks to the role to |
517
|
|
|
|
|
|
|
notify Sub::SymMethod whenever the role gets consumed by a class. Passing |
518
|
|
|
|
|
|
|
C<< no_hooks => 1 >> in the spec will avoid this. |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
This will also perform any needed cache invalidation. |
521
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
=item C<< build_dispatcher( $target, $name ) >> |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
Builds a coderef that could potentially be installed into |
525
|
|
|
|
|
|
|
C<< *{"$target\::$name"} >> to be used as a dispatcher. |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
=item C<< installer_dispatcher( $target, $name ) >> |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
Builds a coderef that could potentially be installed into |
530
|
|
|
|
|
|
|
C<< *{"$target\::$name"} >> to be used as a dispatcher, and |
531
|
|
|
|
|
|
|
actually installs it. |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
This complains if it notices it's overwriting an existing |
534
|
|
|
|
|
|
|
method which isn't a dispatcher. (It also remembers the coderef |
535
|
|
|
|
|
|
|
being installed is a dispatcher, which can later be checked |
536
|
|
|
|
|
|
|
using C<is_dispatcher>.) |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
=item C<< is_dispatcher( $coderef ) >> |
539
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
Checks to see if C<< $coderef >> is a dispatcher. |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
Can also be called as C<< is_dispatcher( $coderef, 0 ) >> or |
543
|
|
|
|
|
|
|
C<< is_dispatcher( $coderef, 1 ) >> to teach it about a coderef. |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
=item C<< dispatch( $invocant, $name, @args ) >> |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
Equivalent to calling C<< $invocant->$name(@args) >> except doesn't use |
548
|
|
|
|
|
|
|
the dispatcher installed into the invocant's class, instead building a |
549
|
|
|
|
|
|
|
new dispatcher and using that. |
550
|
|
|
|
|
|
|
|
551
|
|
|
|
|
|
|
=item C<< install_hooks( $rolename ) >> |
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
Given a role, sets up the required hooks which ensure that when the role |
554
|
|
|
|
|
|
|
is composed with a class, dispatchers will be installed into the class to |
555
|
|
|
|
|
|
|
handle all of the role's symmethods, and Sub::SymMethod will know that the |
556
|
|
|
|
|
|
|
class consumed the role. |
557
|
|
|
|
|
|
|
|
558
|
|
|
|
|
|
|
Also performs cache invalidation. |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=item C<< get_roles_for_class ( $classname ) >> |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
Returns an arrayref containing a list of roles the class is known to |
563
|
|
|
|
|
|
|
consume. We only care about roles that define symmethods. |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
If you need to manually specify that a class consumes a role, you can |
566
|
|
|
|
|
|
|
push the role name onto the arrayref. This would usually only be necessary |
567
|
|
|
|
|
|
|
if you were using an unsupported role implementation. (Supported role |
568
|
|
|
|
|
|
|
implementations include L<Role::Tiny>, L<Role::Basic>, L<Moo::Role>, |
569
|
|
|
|
|
|
|
L<Moose::Role>, and L<Mouse::Role>.) |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=item C<< clear_cache( $name ) >> |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
Clears all caches associated with any symmethods with a given name. |
574
|
|
|
|
|
|
|
The target class is irrelevent because symmethods can be created in |
575
|
|
|
|
|
|
|
roles which may be consumed by multiple unrelated classes. |
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
=item C<< get_symmethod_names( $target ) >> |
578
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
For a given class or role, returns a list of the names of symmethods defined |
580
|
|
|
|
|
|
|
directly in that class or role, not considering inheritance and composition. |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
=item C<< get_symmethods( $target, $name ) >> |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
For a given class or role and a method name, returns an arrayref of spec |
585
|
|
|
|
|
|
|
hashrefs for that symmethod, not considering inheritance and composition. |
586
|
|
|
|
|
|
|
|
587
|
|
|
|
|
|
|
This arrayref can be pushed onto to define more candidates, though this |
588
|
|
|
|
|
|
|
bypasses setting up hooks, installing dispatches, and performing cache |
589
|
|
|
|
|
|
|
invalidation, so C<install_symmethod> is generally preferred unless you're |
590
|
|
|
|
|
|
|
doing something unusual. |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
=item C<< get_all_symmethods( $target, $name ) >> |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
Like C<get_symmethods>, but I<does> consider inheritance and composition. |
595
|
|
|
|
|
|
|
Returns the arrayref of the spec hashrefs in the order they will be called |
596
|
|
|
|
|
|
|
when dispatching. |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
=item C<< compile_signature( \%spec ) >> |
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
When non-coderef signatures are found, this is called to compile them into |
601
|
|
|
|
|
|
|
a coderef. It is a small wrapper around L<Type::Params>. Modifies |
602
|
|
|
|
|
|
|
C<< %spec >> rather than returning a useful value. |
603
|
|
|
|
|
|
|
|
604
|
|
|
|
|
|
|
=item C<< _generate_symmethod( $name, \%opts, \%globalopts ) >> |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
This method is used by C<import> to generate a coderef that will be installed |
607
|
|
|
|
|
|
|
into the called as C<symmethod>. |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
=back |
610
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
=head1 BUGS |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
Please report any bugs to |
614
|
|
|
|
|
|
|
L<http://rt.cpan.org/Dist/Display.html?Queue=Sub-SymMethod>. |
615
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=head1 SEE ALSO |
617
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
L<Sub::MultiMethod>, L<Type::Params>, L<NEXT>. |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
=head1 AUTHOR |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
Toby Inkster E<lt>tobyink@cpan.orgE<gt>. |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENCE |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
This software is copyright (c) 2020 by Toby Inkster. |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
629
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
=head1 DISCLAIMER OF WARRANTIES |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED |
634
|
|
|
|
|
|
|
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF |
635
|
|
|
|
|
|
|
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. |
636
|
|
|
|
|
|
|
|