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