only use one filter for multiple keywords

diff --git a/lib/Filter/Keyword.pm b/lib/Filter/Keyword.pm
index 6b31e99..06df04f 100644 (file)
--- a/lib/Filter/Keyword.pm
+++ b/lib/Filter/Keyword.pm
@@ -1,36 +1,93 @@
 package Filter::Keyword;
-
-use Filter::Util::Call;
-use Filter::Keyword::Parser;
 use Moo;
 
-has parser => (is => 'ro', required => 1);
+use Filter::Keyword::Filter;
+use Scalar::Util qw(weaken);
+use Package::Stash::PP;
+use B qw(svref_2object);
 
-has parser_object => (is => 'lazy');
+sub _compiling_file () {
+  my $depth = 0;
+  while (my @caller = caller(++$depth)) {
+    if ($caller[3] =~ /::BEGIN$/) {
+      # older perls report the BEGIN in the wrong file
+      return $depth > 1 ? (caller($depth-1))[1] : $caller[1];
+      #return $caller[1];
+    }
+  }
+  die;
+}
 
-sub _build_parser_object {
+my %filters;
+sub install {
   my ($self) = @_;
-  my %args = %{$self->parser};
-  $args{reader} = sub { my $r = filter_read; ($_, $r) };
-  $args{re_add} = sub {
-    my $parser = shift;
-    filter_add(sub {
-      my ($string, $code) = $parser->get_next;
-      $_ = $string;
-      return $code;
-    });
-  };
-  Filter::Keyword::Parser->new(\%args);
+  my $file = _compiling_file;
+  $self->shadow_sub;
+  my $filter = $filters{$file} ||= Filter::Keyword::Filter->new;
+  $filter->install;
+  my $parser = $filter->parser;
+  $parser->add_keyword($self);
+  $self->keyword_parser($parser);
 }
 
-sub install {
+sub shadow_sub {
+  my $self = shift;
+  my $stash = $self->stash;
+  if (my $shadowed = $stash->get_symbol('&'.$self->keyword_name)) {
+    $stash->remove_symbol('&'.$self->keyword_name);
+    $stash->add_symbol('&__'.$self->keyword_name, $shadowed);
+  }
+}
+
+sub remove {
+  my ($self) = @_;
+  $self->keyword_parser->remove_keyword($self);
+  $self->clear_keyword_parser;
+  $self->clear_globref;
+}
+
+has keyword_parser => (is => 'rw', weak_ref => 1, clearer => 1);
+
+has target_package => (is => 'ro', required => 1);
+has keyword_name   => (is => 'ro', required => 1);
+has parser         => (is => 'ro', required => 1);
+
+has stash => (is => 'lazy');
+
+sub _build_stash {
+  my ($self) = @_;
+  Package::Stash::PP->new($self->target_package);
+}
+
+has globref => (is => 'lazy', clearer => 'clear_globref');
+
+sub _build_globref {
+  no strict 'refs'; no warnings 'once';
+  \*{join'::',$_[0]->target_package,$_[0]->keyword_name}
+}
+
+after clear_globref => sub {
+  my ($self) = @_;
+  $self->stash->remove_symbol('&'.$self->keyword_name);
+  $self->globref_refcount(undef);
+};
+
+has globref_refcount => (is => 'rw');
+
+sub save_refcount {
+  my ($self) = @_;
+  $self->globref_refcount(svref_2object($self->globref)->REFCNT);
+}
+
+sub have_match {
+  my ($self) = @_;
+  return 0 unless defined($self->globref_refcount);
+  svref_2object($self->globref)->REFCNT > $self->globref_refcount;
+}
+
+sub DEMOLISH {
   my ($self) = @_;
-  my $parser = $self->parser_object;
-  filter_add(sub {
-    my ($string, $code) = $parser->get_next;
-    $_ = $string;
-    return $code;
-  });
+  $self->remove;
 }
 
 1;

diff --git a/lib/Filter/Keyword/Filter.pm b/lib/Filter/Keyword/Filter.pm
new file mode 100644 (file)
index 0000000..4fb181c
--- /dev/null
+++ b/lib/Filter/Keyword/Filter.pm
@@ -0,0 +1,41 @@
+package Filter::Keyword::Filter;
+use Moo;
+
+use Filter::Keyword::Parser;
+use Filter::Util::Call;
+use Scalar::Util qw(weaken);
+use B::Hooks::EndOfScope;
+
+has parser => (is => 'lazy');
+has active => (is => 'rwp', default => 0);
+
+sub _build_parser {
+  my $self = shift;
+  weaken $self;
+  Filter::Keyword::Parser->new(
+    reader => sub { my $r = filter_read; ($_, $r) },
+    re_add => sub { filter_add($self) },
+  );
+}
+
+sub install {
+  my ($self) = @_;
+  return if $self->active;
+  $self->_set_active(1);
+  filter_add($self);
+  on_scope_end {
+    $self->_set_active(0);
+    filter_del;
+  };
+  $self;
+}
+
+sub filter {
+  my ($self) = @_;
+  my ($string, $code) = $self->parser->get_next;
+  $_ = $string;
+  return $code;
+}
+
+1;
+

diff --git a/lib/Filter/Keyword/Parser.pm b/lib/Filter/Keyword/Parser.pm
index 6f4c8fb..7b9a3c4 100644 (file)
--- a/lib/Filter/Keyword/Parser.pm
+++ b/lib/Filter/Keyword/Parser.pm
@@ -1,51 +1,26 @@
 package Filter::Keyword::Parser;
-
-use Package::Stash::PP;
-use B qw(svref_2object);
-use Scalar::Util qw(set_prototype);
 use Moo;
 
-has parser => (is => 'ro', required => 1);
+use Scalar::Util qw(set_prototype);
 
 has reader => (is => 'ro', required => 1);
 
 has re_add => (is => 'ro', required => 1);
 
-has target_package => (is => 'ro', required => 1);
-
-has keyword_name => (is => 'ro', required => 1);
-
-has stash => (is => 'lazy');
-
-sub _build_stash {
-  my ($self) = @_;
-  Package::Stash::PP->new($self->target_package);
-}
-
-has globref => (is => 'lazy', clearer => 'clear_globref');
+has keywords => (is => 'ro', default => sub { [] });
 
-sub _build_globref {
-  no strict 'refs'; no warnings 'once';
-  \*{join'::',$_[0]->target_package,$_[0]->keyword_name}
+sub add_keyword {
+  push @{$_[0]->keywords}, $_[1];
 }
-
-after clear_globref => sub {
-  my ($self) = @_;
-  $self->stash->remove_symbol('&'.$self->keyword_name);
-  $self->globref_refcount(undef);
-};
-
-has globref_refcount => (is => 'rw');
-
-sub save_refcount {
-  my ($self) = @_;
-  $self->globref_refcount(svref_2object($self->globref)->REFCNT);
-}
-
-sub have_match {
-  my ($self) = @_;
-  return 0 unless defined($self->globref_refcount);
-  svref_2object($self->globref)->REFCNT > $self->globref_refcount;
+sub remove_keyword {
+  my ($self, $keyword) = @_;
+  my $keywords = $self->keywords;
+  for my $idx (0 .. $#$keywords) {
+    if ($keywords->[$idx] eq $keyword) {
+      splice @$keywords, $idx, 1;
+      last;
+    }
+  }
 }
 
 has current_match => (is => 'rw');
@@ -61,9 +36,11 @@ sub get_next {
     $self->${\$self->re_add};
     return ('', 0);
   }
-  if ($self->have_match) {
-    $self->clear_globref;
-    return $self->${\$self->parser};
+  for my $keyword (@{$self->keywords}) {
+    if ($keyword->have_match) {
+      $keyword->clear_globref;
+      return $keyword->parser->($keyword, $self);
+    }
   }
   return $self->check_match;
 }
@@ -71,7 +48,7 @@ sub get_next {
 sub fetch_more {
   my ($self) = @_;
   my $code = $self->code||'';
-  my ($extra_code, $not_eof) = $self->${\$self->reader};
+  my ($extra_code, $not_eof) = $self->reader->();
   $code .= $extra_code;
   $self->code($code);
   return $not_eof;
@@ -94,19 +71,21 @@ sub check_match {
     $self->fetch_more
       or return ('', 0);
   }
-  if (
-    my ($stripped, $matches)
-      = $self->match_source(
-          $self->keyword_name, qr/(\(|[A-Za-z][A-Za-z_0-9]*|{)/
-        )
-  ) {
-    my $sub = sub {};
-    set_prototype(\&$sub, '*;@') unless $matches->[0] eq '(';
-    { no warnings 'redefine'; *{$self->globref} = $sub; }
-    $self->save_refcount;
-    $self->current_match($matches);
-    $self->short_circuit(1);
-    return ($stripped, 1);
+  for my $keyword (@{ $self->keywords }) {
+    if (
+      my ($stripped, $matches)
+        = $self->match_source(
+            $keyword->keyword_name, qr/(\(|[A-Za-z][A-Za-z_0-9]*|{)/
+          )
+    ) {
+      my $sub = sub {};
+      set_prototype(\&$sub, '*;@') unless $matches->[0] eq '(';
+      { no warnings 'redefine', 'prototype'; *{$keyword->globref} = $sub; }
+      $keyword->save_refcount;
+      $self->current_match($matches);
+      $self->short_circuit(1);
+      return ($stripped, 1);
+    }
   }
   my $code = $self->code;
   $self->code('');