File Coverage

blib/lib/Sub/SymMethod.pm
Criterion Covered Total %
statement 145 159 91.1
branch 38 50 76.0
condition 14 27 51.8
subroutine 30 30 100.0
pod 11 12 91.6
total 238 278 85.6


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