File Coverage

blib/lib/Devel/Declare/MethodInstaller/Simple.pm
Criterion Covered Total %
statement 65 65 100.0
branch 10 10 100.0
condition n/a
subroutine 17 18 94.4
pod 0 6 0.0
total 92 99 92.9


line stmt bran cond sub pod time code
1             package Devel::Declare::MethodInstaller::Simple;
2              
3 4     4   279868 use base 'Devel::Declare::Context::Simple';
  4         42  
  4         1919  
4              
5 4     4   30 use Devel::Declare ();
  4         9  
  4         68  
6 4     4   1996 use Sub::Name;
  4         2090  
  4         201  
7 4     4   28 use strict;
  4         9  
  4         78  
8 4     4   19 use warnings;
  4         9  
  4         317  
9              
10             our $VERSION = '0.006022';
11             $VERSION =~ tr/_//d;
12              
13             sub install_methodhandler {
14 5     5 0 262 my $class = shift;
15 5         22 my %args = @_;
16             {
17 4     4   27 no strict 'refs';
  4         11  
  4         978  
  5         12  
18 5     0   24 *{$args{into}.'::'.$args{name}} = sub (&) {};
  5         33  
19             }
20              
21 5         653 my $warnings = warnings::enabled("redefine");
22 5         46 my $ctx = $class->new(%args);
23             Devel::Declare->setup_for(
24             $args{into},
25 18     18   72 { $args{name} => { const => sub { $ctx->parser(@_, $warnings) } } }
26 5         60 );
27             }
28              
29             sub code_for {
30 18     18 0 66 my ($self, $name) = @_;
31              
32 18 100       47 if (defined $name) {
33 14         44 my $pkg = $self->get_curstash_name;
34 14 100       70 $name = join( '::', $pkg, $name )
35             unless( $name =~ /::/ );
36             return sub (&) {
37 11     11   3619 my $code = shift;
38             # So caller() gets the subroutine name
39 4     4   33 no strict 'refs';
  4         9  
  4         333  
40             my $installer = $self->warning_on_redefine
41 10         62 ? sub { *{$name} = subname $name => $code; }
  10         89  
42 4     4   28 : sub { no warnings 'redefine';
  4         9  
  4         1522  
43 11 100       64 *{$name} = subname $name => $code; };
  1         8  
  1         8  
44 11         36 $installer->();
45 11         63 return;
46 14         112 };
47             } else {
48 4     4   31 return sub (&) { shift };
  4         29  
49             }
50             }
51              
52             sub install {
53 18     18 0 38 my ($self, $name ) = @_;
54              
55 18         49 $self->shadow( $self->code_for($name) );
56             }
57              
58             sub parser {
59 18     18 0 32 my $self = shift;
60 18         82 $self->init(@_);
61              
62 18         70 $self->skip_declarator;
63 18         52 my $name = $self->strip_name;
64 18         62 my $proto = $self->strip_proto;
65 18         56 my $attrs = $self->strip_attrs;
66 18         47 my @decl = $self->parse_proto($proto);
67 18         139 my $inject = $self->inject_parsed_proto(@decl);
68 18 100       49 if (defined $name) {
69 14         43 $inject = $self->scope_injector_call() . $inject;
70             }
71 18 100       82 $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : '');
72              
73 18         59 $self->install( $name );
74              
75 18         118 return;
76             }
77              
78 8     8 0 33 sub parse_proto { '' }
79              
80             sub inject_parsed_proto {
81 18     18 0 44 return $_[1];
82             }
83              
84             1;
85