lib/Filter/Keyword/Parser.pm

   1 package Filter::Keyword::Parser;
   2 use Moo;
   3
   4 use Scalar::Util qw(set_prototype);
   5
   6 has reader => (is => 'ro', required => 1);
   7
   8 has re_add => (is => 'ro', required => 1);
   9
  10 has keywords => (is => 'ro', default => sub { [] });
  11
  12 sub add_keyword {
  13   push @{$_[0]->keywords}, $_[1];
  14 }
  15 sub remove_keyword {
  16   my ($self, $keyword) = @_;
  17   my $keywords = $self->keywords;
  18   for my $idx (0 .. $#$keywords) {
  19     if ($keywords->[$idx] eq $keyword) {
  20       splice @$keywords, $idx, 1;
  21       last;
  22     }
  23   }
  24 }
  25
  26 has current_match => (is => 'rw');
  27
  28 has short_circuit => (is => 'rw');
  29
  30 has code => (is => 'rw', default => sub { '' });
  31
  32 sub get_next {
  33   my ($self) = @_;
  34   if ($self->short_circuit) {
  35     $self->short_circuit(0);
  36     $self->${\$self->re_add};
  37     return ('', 0);
  38   }
  39   for my $keyword (@{$self->keywords}) {
  40     if ($keyword->have_match) {
  41       $keyword->clear_globref;
  42       return $keyword->parser->($keyword, $self);
  43     }
  44   }
  45   return $self->check_match;
  46 }
  47
  48 sub fetch_more {
  49   my ($self) = @_;
  50   my $code = $self->code||'';
  51   my ($extra_code, $not_eof) = $self->reader->();
  52   $code .= $extra_code;
  53   $self->code($code);
  54   return $not_eof;
  55 }
  56
  57 sub match_source {
  58   my ($self, $first, $second) = @_;
  59   $self->fetch_more while $self->code =~ /$first\s+\Z/;
  60   if (my @match = ($self->code =~ /(.*?${first}\s+${second})(.*)\Z/)) {
  61     $self->code(pop @match);
  62     my $found = shift(@match);
  63     return ($found, \@match);
  64   }
  65   return;
  66 }
  67
  68 sub check_match {
  69   my ($self) = @_;
  70   unless ($self->code) {
  71     $self->fetch_more
  72       or return ('', 0);
  73   }
  74   for my $keyword (@{ $self->keywords }) {
  75     if (
  76       my ($stripped, $matches)
  77         = $self->match_source(
  78             $keyword->keyword_name, qr/(\(|[A-Za-z][A-Za-z_0-9]*|{)/
  79           )
  80     ) {
  81       my $sub = sub {};
  82       set_prototype(\&$sub, '*;@') unless $matches->[0] eq '(';
  83       { no warnings 'redefine', 'prototype'; *{$keyword->globref} = $sub; }
  84       $keyword->save_refcount;
  85       $self->current_match($matches);
  86       $self->short_circuit(1);
  87       return ($stripped, 1);
  88     }
  89   }
  90   my $code = $self->code;
  91   $self->code('');
  92   return ($code, 1);
  93 }
  94
  95 1;