File Coverage

blib/lib/Class/Method/ModifiersX/Augment.pm
Criterion Covered Total %
statement 54 56 96.4
branch 5 8 62.5
condition n/a
subroutine 13 13 100.0
pod 2 2 100.0
total 74 79 93.6


line stmt bran cond sub pod time code
1             package Class::Method::ModifiersX::Augment;
2              
3 2     2   41041 use 5.008;
  2         7  
  2         91  
4 2     2   10 use strict;
  2         13  
  2         86  
5 2     2   12 use warnings;
  2         8  
  2         115  
6              
7             BEGIN {
8 2     2   4 $Class::Method::ModifiersX::Augment::AUTHORITY = 'cpan:TOBYINK';
9 2         47 $Class::Method::ModifiersX::Augment::VERSION = '0.002';
10             }
11              
12 2     2   11 use base qw(Exporter);
  2         3  
  2         301  
13             our %EXPORT_TAGS = (
14             all => [our @EXPORT_OK = our @EXPORT = qw( augment inner )],
15             );
16              
17 2     2   1952 use Class::Method::Modifiers qw( install_modifier );
  2         2723  
  2         148  
18              
19 2     2   1887 use if ($] >= 5.010), 'mro';
  2         16  
  2         11  
20 2     2   2927 use if ($] < 5.010), 'MRO::Compat';
  2         4  
  2         12  
21              
22             our %INNER_BODY = ();
23             our %INNER_ARGS = ();
24              
25             sub _mk_around
26             {
27 2     2   4 my ($into, $code, $name) = @_;
28 2 50       5 unless ($name)
29             {
30 0         0 require Carp;
31 0         0 Carp::croak("need name");
32             }
33            
34 2         3 my $super;
35 2         3 my @isa = @{ mro::get_linear_isa($into) };
  2         18  
36 2         3 shift @isa;
37 2         3 SUPER: foreach my $pkg (@isa)
38             {
39 2     2   276 no strict qw(refs);
  2         4  
  2         567  
40 2 50       3 if (exists &{"${pkg}::${name}"})
  2         12  
41             {
42 2 50       11 $super = $pkg and last SUPER;
43             }
44             }
45            
46             return sub {
47 3     3   68 my $super_body = shift;
48 3         8 local $INNER_ARGS{$super} = [ @_ ];
49 3         6 local $INNER_BODY{$super} = $code;
50 3         25 return $super_body->(@_);
51 2         12 };
52             }
53              
54             sub augment
55             {
56 2     2 1 376 my $into = caller(0);
57 2         3 my $code = pop;
58            
59 2         7 foreach my $name (@_)
60             {
61 2         6 my $sub = _mk_around($into, $code, $name);
62 2         8 install_modifier($into, 'around', $name, $sub);
63             }
64             }
65              
66             sub inner ()
67             {
68 5     5 1 253 my $pkg = caller;
69            
70 5 100       14 if (my $body = $INNER_BODY{$pkg}) {
71 3         4 my @args = @{ $INNER_ARGS{$pkg} };
  3         23  
72 3         9 local $INNER_ARGS{$pkg};
73 3         4 local $INNER_BODY{$pkg};
74 3         8 return $body->(@args);
75             }
76            
77 2         26 return;
78             }
79              
80              
81              
82             1;
83              
84             __END__