Random notes

2010. 11. 29

Devel::Declare, Method::Signatures, oh my

Actually, I got another inspiration from Method::Signatures, for use with CGI::Application.

But while implementing that, I decided to extract the hard Devel::Declare bits, and make a macro installer.

Here’s a re-implementation of Method::Signatures using my Devel::Declare::Macro:

 package Method::Signatures;
 use Devel::Declare::Macro;

 sub import {
  install_macro(
    into           => scalar(caller),
    name           => 'method',
    proto_parser   => \&make_proto_unwrap,
    proto_injector => \&inject_from_signature
  );
 }

 sub make_proto_unwrap {} # as before, except return \%signature
 sub inject_from_signature {} # as before
 1;

I’m somewhat confident it could simplify the implementation of Sub::Curried and MooseX::Method::Signatures as well.

Basically it packages the synopsis of Devel::Declare. As such, I don’t think I should maintain it. Comments welcome.

  package Devel::Macro;

  sub import {
      my $class = shift;
      my $pkg = caller;
      no strict 'refs';
      *{$pkg.'::install_macro'} = \&install_macro;
  }

  # Stolen from Devel::Declare's t/method-no-semi.t
  use Devel::Declare ();
  use Scope::Guard;
  use Sub::Name;
  sub install_macro {
      my %args   = @_;
      # I don't really understand why we need to declare method
      # in the caller's namespace.
      {
          no strict 'refs';
          *{$args{into}.'::'.$args{name}}   = sub (&) {};
      }
      Devel::Declare->setup_for(
          $args{into},
          { $args{name} => {
              const => mk_parser(
                  $args{proto_parser}||sub{''},
                  $args{proto_injector}||sub{join' ', @_},
                  $args{pre_install}||sub{},
                  )
              },
          },
      );

  }
  our ($Declarator, $Offset);

  sub skip_declarator {
      $Offset += Devel::Declare::toke_move_past_token($Offset);
  }

  sub skipspace {
      $Offset += Devel::Declare::toke_skipspace($Offset);
  }

  sub strip_name {
      skipspace;
      if (my $len = Devel::Declare::toke_scan_word($Offset, 1)) {
          my $linestr = Devel::Declare::get_linestr();
          my $name = substr($linestr, $Offset, $len);
          substr($linestr, $Offset, $len) = '';
          Devel::Declare::set_linestr($linestr);
          return $name;
      }
      return;
  }

  sub strip_proto {
      skipspace;

      my $linestr = Devel::Declare::get_linestr();
      if (substr($linestr, $Offset, 1) eq '(') {
          my $length = Devel::Declare::toke_scan_str($Offset);
          my $proto = Devel::Declare::get_lex_stuff();
          Devel::Declare::clear_lex_stuff();
          $linestr = Devel::Declare::get_linestr();
          substr($linestr, $Offset, $length) = '';
          Devel::Declare::set_linestr($linestr);
          return $proto;
      }
      return;
  }

  sub shadow {
      my $pack = Devel::Declare::get_curstash_name;
      Devel::Declare::shadow_sub("${pack}::${Declarator}", $_[0]);
  }

  sub inject_if_block {
      my $inject = shift;
      skipspace;
      my $linestr = Devel::Declare::get_linestr;
      if (substr($linestr, $Offset, 1) eq '{') {
          substr($linestr, $Offset+1, 0) = $inject;
          Devel::Declare::set_linestr($linestr);
      }
  }

  sub scope_injector_call {
      return ' BEGIN { ' . __PACKAGE__ . '::inject_scope }; ';
  }

  sub mk_parser {
      my $proto_parser   = shift;
      my $proto_injector = shift;
      my $install_cb     = shift;

      return sub {
      local ($Declarator, $Offset) = @_;
      skip_declarator;
      my $name = strip_name;
      my $proto = strip_proto;
      my @decl = $proto_parser->($proto);
      my $inject = $proto_injector->(@decl);
      if (defined $name) {
          $inject = scope_injector_call().$inject;
      }
      inject_if_block($inject);
      if (defined $name) {
          $name = join('::', Devel::Declare::get_curstash_name(), $name)
            unless ($name =~ /::/);
      }
      shadow(sub (&) {
          no strict 'refs';
          my $code = shift;
          $install_cb->($name, $code, \@decl);
          # So caller() gets the subroutine name
          *{$name} = subname $name => $code if defined $name;
      });
      };
  }

  sub inject_scope {
      $^H |= 0x120000;
      $^H{DD_METHODHANDLERS} = Scope::Guard->new(sub {
          my $linestr = Devel::Declare::get_linestr;
          my $offset = Devel::Declare::get_linestr_offset;
          substr($linestr, $offset, 0) = ';';
          Devel::Declare::set_linestr($linestr);
      });
  }

  1;

No comments yet [ / programming / perl ] permalink

---