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.006022';
  11 $VERSION =~ tr/_//d;
  12
  13 sub install_methodhandler {
  14   my $class = shift;
  15   my %args  = @_;
  16   {
  17     no strict 'refs';
  18     *{$args{into}.'::'.$args{name}}   = sub (&) {};
  19   }
  20
  21   my $warnings = warnings::enabled("redefine");
  22   my $ctx = $class->new(%args);
  23   Devel::Declare->setup_for(
  24     $args{into},
  25     { $args{name} => { const => sub { $ctx->parser(@_, $warnings) } } }
  26   );
  27 }
  28
  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';
  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->();
  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
  58 sub parser {
  59   my $self = shift;
  60   $self->init(@_);
  61
  62   $self->skip_declarator;
  63   my $name   = $self->strip_name;
  64   my $proto  = $self->strip_proto;
  65   my $attrs  = $self->strip_attrs;
  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   }
  71   $self->inject_if_block($inject, $attrs ? "sub ${attrs} " : '');
  72
  73   $self->install( $name );
  74
  75   return;
  76 }
  77
  78 sub parse_proto { '' }
  79
  80 sub inject_parsed_proto {
  81   return $_[1];
  82 }
  83
  84 1;
  85