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