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 sub install_methodhandler {
  11   my $class = shift;
  12   my %args  = @_;
  13   {
  14     no strict 'refs';
  15     *{$args{into}.'::'.$args{name}}   = sub (&) {};
  16   }
  17
  18   my $ctx = $class->new(%args);
  19   Devel::Declare->setup_for(
  20     $args{into},
  21     { $args{name} => { const => sub { $ctx->parser(@_) } } }
  22   );
  23 }
  24
  25 sub parser {
  26   my $self = shift;
  27   $self->init(@_);
  28
  29   $self->skip_declarator;
  30   my $name   = $self->strip_name;
  31   my $proto  = $self->strip_proto;
  32   my @decl   = $self->parse_proto($proto);
  33   my $inject = $self->inject_parsed_proto(@decl);
  34   if (defined $name) {
  35     $inject = $self->scope_injector_call() . $inject;
  36   }
  37   $self->inject_if_block($inject);
  38   if (defined $name) {
  39     my $pkg = $self->get_curstash_name;
  40     $name = join( '::', $pkg, $name )
  41       unless( $name =~ /::/ );
  42     $self->shadow( sub (&) {
  43       my $code = shift;
  44       # So caller() gets the subroutine name
  45       no strict 'refs';
  46       *{$name} = subname $name => $code;
  47     });
  48   } else {
  49     $self->shadow(sub (&) { shift });
  50   }
  51 }
  52
  53 sub parse_proto { }
  54
  55 sub inject_parsed_proto {
  56   return $_[1];
  57 }
  58
  59 1;
  60