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
  26 sub parser {
  27     my $ctx = shift;
  28     $ctx->init(@_);
  29
  30     $ctx->skip_declarator;
  31     my $name   = $ctx->strip_name;
  32     my $proto  = $ctx->strip_proto;
  33     my @decl   = $ctx->parse_proto($proto);
  34     my $inject = $ctx->inject_parsed_proto(@decl);
  35     if( defined $name ) {
  36         $inject = $ctx->scope_injector_call() . $inject;
  37     }
  38     $ctx->inject_if_block($inject);
  39     if( defined $name ) {
  40         my $pkg = $ctx->get_curstash_name;
  41         $name = join( '::', $pkg, $name )
  42             unless( $name =~ /::/ );
  43         $ctx->shadow( sub (&) {
  44             my $code = shift;
  45             # So caller() gets the subroutine name
  46             no strict 'refs';
  47             *{$name} = subname $name => $code;
  48         });
  49     } else {
  50         $ctx->shadow(sub (&) { shift });
  51     }
  52 }
  53 sub parse_proto { }
  54 sub inject_parsed_proto {
  55     my $ctx = shift;
  56     shift;
  57 }
  58
  59
  60 1;
  61