lib/Filter/Keyword/Parser.pm

   1 package Filter::Keyword::Parser;
   2
   3 use Package::Stash::PP;
   4 use B qw(svref_2object);
   5 use Scalar::Util qw(set_prototype);
   6 use Moo;
   7
   8 has parser => (is => 'ro', required => 1);
   9
  10 has reader => (is => 'ro', required => 1);
  11
  12 has re_add => (is => 'ro', required => 1);
  13
  14 has target_package => (is => 'ro', required => 1);
  15
  16 has keyword_name => (is => 'ro', required => 1);
  17
  18 has stash => (is => 'lazy');
  19
  20 sub _build_stash {
  21   my ($self) = @_;
  22   Package::Stash::PP->new($self->target_package);
  23 }
  24
  25 has globref => (is => 'lazy', clearer => 'clear_globref');
  26
  27 sub _build_globref {
  28   no strict 'refs'; no warnings 'once';
  29   \*{join'::',$_[0]->target_package,$_[0]->keyword_name}
  30 }
  31
  32 after clear_globref => sub {
  33   my ($self) = @_;
  34   $self->stash->remove_symbol('&'.$self->keyword_name);
  35   $self->globref_refcount(undef);
  36 };
  37
  38 has globref_refcount => (is => 'rw');
  39
  40 sub save_refcount {
  41   my ($self) = @_;
  42   $self->globref_refcount(svref_2object($self->globref)->REFCNT);
  43 }
  44
  45 sub have_match {
  46   my ($self) = @_;
  47   return 0 unless defined($self->globref_refcount);
  48   svref_2object($self->globref)->REFCNT > $self->globref_refcount;
  49 }
  50
  51 has current_match => (is => 'rw');
  52
  53 has short_circuit => (is => 'rw');
  54
  55 has code => (is => 'rw', default => sub { '' });
  56
  57 sub get_next {
  58   my ($self) = @_;
  59   if ($self->short_circuit) {
  60     $self->short_circuit(0);
  61     $self->${\$self->re_add};
  62     return ('', 0);
  63   }
  64   if ($self->have_match) {
  65     $self->clear_globref;
  66     return $self->${\$self->parser};
  67   }
  68   return $self->check_match;
  69 }
  70
  71 sub fetch_more {
  72   my ($self) = @_;
  73   my $code = $self->code||'';
  74   my ($extra_code, $not_eof) = $self->${\$self->reader};
  75   $code .= $extra_code;
  76   $self->code($code);
  77   return $not_eof;
  78 }
  79
  80 sub match_source {
  81   my ($self, $first, $second) = @_;
  82   $self->fetch_more while $self->code =~ /$first\s+\Z/;
  83   if (my @match = ($self->code =~ /(.*?${first}\s+${second})(.*)\Z/)) {
  84     $self->code(pop @match);
  85     my $found = shift(@match);
  86     return ($found, \@match);
  87   }
  88   return;
  89 }
  90
  91 sub check_match {
  92   my ($self) = @_;
  93   unless ($self->code) {
  94     $self->fetch_more
  95       or return ('', 0);
  96   }
  97   if (
  98     my ($stripped, $matches)
  99       = $self->match_source(
 100           $self->keyword_name, qr/(\(|[A-Za-z][A-Za-z_0-9]*|{)/
 101         )
 102   ) {
 103     my $sub = sub {};
 104     set_prototype(\&$sub, '*;@') unless $matches->[0] eq '(';
 105     { no warnings 'redefine'; *{$self->globref} = $sub; }
 106     $self->save_refcount;
 107     $self->current_match($matches);
 108     $self->short_circuit(1);
 109     return ($stripped, 1);
 110   }
 111   my $code = $self->code;
 112   $self->code('');
 113   return ($code, 1);
 114 }
 115
 116 1;