view release on metacpan or  search on metacpan

lib/Babble/Plugin/CoreSignatures.pm  view on Meta::CPAN

package Babble::Plugin::CoreSignatures;

use strictures 2;
use Moo;

sub extend_grammar { } # PPR::X can already parse everything we need

# .......bbbbbSSSSSSSa
# sub foo :Bar ($baz) {

# .......bSSSSSSSaaaaa
# sub foo ($baz) :Bar {

sub transform_to_signatures {
  my ($self, $top) = @_;
  my $tf = sub {
    my $s = (my $m = shift)->submatches;
    if ((my $after = $s->{after}->text) =~ /\S/) {
      $s->{after}->replace_text('');
      $s->{before}->replace_text($s->{before}->text.$after);
    }
  };
  $self->_transform_signatures($top, $tf);
}

sub transform_to_oldsignatures {
  my ($self, $top) = @_;
  my $tf = sub {
    my $s = (my $m = shift)->submatches;
    if ((my $before = $s->{before}->text) =~ /\S/) {
      $s->{before}->replace_text('');
      $s->{after}->replace_text($before.$s->{after}->text);
    }
  };
  $self->_transform_signatures($top, $tf);
}

sub transform_to_plain {
  my ($self, $top) = @_;
  $top->remove_use_argument(experimental => 'signatures');
  $top->remove_use_argument('Mojo::Base' => '-signatures', 1);
  my $tf = sub {
    my $s = (my $m = shift)->submatches;

    # shift attributes after first before we go hunting for :prototype
    if ((my $before = $s->{before}->text) =~ /\S/) {
      $s->{before}->replace_text('');
      $s->{after}->replace_text($before.$s->{after}->text);
    }

    my $proto = '';
    {
      my $try = $s->{after};
      local $try->{top_rule} = 'Attributes';
      my $grammar = $m->grammar->clone;
      $grammar->add_rule(Attribute =>
        '(?&PerlOWS) :? (?&PerlOWS)
         (?&PerlIdentifier)
         (?: (?= \( ) (?&PPR_X_quotelike_body) )?+'
      )->replace_rule(Attributes =>
        '(?=(?&PerlOWS):)(?&PerlAttribute)
         (?&PerlAttribute)*'
      );
      local $try->{grammar} = $grammar;
      my $each; $each = sub {
        my ($attr) = @_;
        if ($attr->text =~ /prototype(\(.*?\))/) {
          $proto = $1;
          $attr->replace_text('');
          $each = sub {
            my ($attr) = @_;
            $attr->transform_text(sub { s/^(\s*)/${1}:/ }) unless $attr->text =~ /^\s*:/;
            $each = sub {};
          };
        }
      };
      $try->each_match_of(Attribute => sub { $each->(@_) });
      undef($each);
    }

    s/\A\s*\(//, s/\)\s*\Z// for my $sig_orig = $s->{sig}->text;
    my $grammar_re = $m->grammar_regexp;
    my @sig_parts = grep defined($_),
                      $sig_orig =~ /((?&PerlAssignment)) ${grammar_re}/xg;

    my (@sig_text, @defaults);