view release on metacpan or  search on metacpan

devel/MyExtractUse.pm  view on Meta::CPAN

         create => "(?:^|\n)(?:^|\n)(=[[:alpha:]][^\n]*\n.*?\n)?=cut(\n|\$)(\n|\$)");

# ENHANCE-ME: also q{} etc strings
pattern (name   => ['Perl','string'],
         create => sub { $RE{delimited}{-delim=>'"\''}{-esc=>'\\\\'} });


package MyExtractUse;
use strict;
use warnings;
use Perl6::Slurp;
use Pod::Strip;
use Regexp::Common;

use constant DEBUG => 0;

print "RE lws $RE{Perl}{lws}\n";
my $lws = qr/$RE{Perl}{lws}/o;
my $use_re
  = qr{\b(?<type>use|require|no)
       $lws
       (?<package>$RE{Perl}{qualified})
       ($lws(?<version>$RE{Perl}{version}))?
    }ox;
my $use_code_re
  = qr{(?<eval>eval${lws}?\{)?
       ${lws}?
       $use_re}ox;
my $use_eval_string_re
  = qr{(?<eval>eval${lws}?['"]
       ${lws}?
       $use_re)}ox;
my $use_base_re
  = qr{\b(?<type>use)${lws}base
       $lws
       (\($lws)?['"](?<package>$RE{Perl}{qualified})
    }ox;
my $use_perl_re
  = qr{\b(?<type>use|no|require)
       ${lws}
       (?<version>$RE{Perl}{version})
      }ox;
my $VERSION_check_re
  = qr{\b(?<package>$RE{Perl}{qualified})
      $lws
      ->
      $lws
      VERSION
      $lws
      \(
      $lws
      ['"]?(?<version>$RE{Perl}{version})
      }ox;

# my $re = $use_eval_string_re;
# print "re: $re\n";
# my $str = "eval 'use Foo::Bar 3; 1' ";
# print "str: $str\n";
# if ($str =~ $use_eval_string_re) {
#   print "match\n";
#   require Data::Dumper;
#   print Data::Dumper::Dumper(\%+);
# } else {
#   print "no match\n";
# }
# exit 0;


sub from_file {
  my ($class, $filename) = @_;
  ### from_file(): $filename
  return if ($filename =~ m{selfloader-fork\.pl$});
  return $class->from_string (scalar Perl6::Slurp::slurp($filename));
}
sub from_string {
  my ($class, $str) = @_;

  my @ret;
  my $one = sub {
    my ($re) = @_;
    if (DEBUG >= 2) { print $str; }

    while ($str =~ /$re/g) {
      my %ret = %+;
      $ret{'pos'} = pos($str);
      $ret{'version'} = version->new($ret{'version'} || 0);
      push @ret, \%ret;

      if (DEBUG) {
        require Data::Dumper;
        print Data::Dumper::Dumper(\%ret);
      }
    }
  };

  #  $str = _pod_to_comments ($str);
  $str = _pod_to_whitespace ($str);
  $str = _comments_to_whitespace ($str);
  $str = _heredoc_to_whitespace ($str);

  $one->($use_base_re);
  $one->($use_eval_string_re);
  $one->($VERSION_check_re);
  $str = _strings_to_whitespace ($str);
  $one->($use_code_re);

  return @ret;
}

my $heredoc_re = qr/<<(?<open>['"]|)(?<word>$RE{Perl}{identifier})\k<open>(.*\n)+?\k<word>/;
  #$str =~ s/($heredoc_re)/_to_whitespace($1)/ego;

sub _heredoc_to_whitespace {
  my ($str) = @_;
  ### _heredoc_to_whitespace()
  while ($str =~ /<<['"]?($RE{Perl}{identifier})/) {
    my $pos = $-[0];
    my $word = $1;
    my $end = index ($str, "\n$word", $pos);
    if ($end < 0) { $end = length($str); }
    substr ($str, $pos, $end-$pos, '');
  }
  ### return: length($str)
  return $str;
}
# print _heredoc_to_whitespace('
#   show <<"HERE";
# foo ""
# HERE
# bar
#   xxx <<EOF;
# EOF
# ');
# exit 0;

sub _comments_to_whitespace {
  my ($str) = @_;
  $str =~ s/($RE{comment}{Perl})/_to_whitespace($1)/ego;
  return $str;
}

sub _pod_to_comments {
  my ($str) = @_;
  ### _pod_to_comments()
  my $stripper = Pod::Strip->new;
  $stripper->replace_with_comments (1);
  my $out;
  $stripper->output_string (\$out);
  $stripper->parse_string_document ($str);
  return $out;
}