From: Matt S Trout <mst@shadowcat.co.uk>
Date: Wed, 14 Dec 2011 11:59:12 +0000 (+0000)
Subject: factor out Filter::Keyword::Parser
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FFilter-Keyword.git;a=commitdiff_plain;h=HEAD

factor out Filter::Keyword::Parser
---

diff --git a/lib/Filter/Keyword.pm b/lib/Filter/Keyword.pm
index 9d01adf..6b31e99 100644
--- a/lib/Filter/Keyword.pm
+++ b/lib/Filter/Keyword.pm
@@ -1,96 +1,36 @@
 package Filter::Keyword;
 
-# we need the PP implementation's version of remove_symbol
-use Package::Stash::PP;
 use Filter::Util::Call;
-use B qw(svref_2object);
+use Filter::Keyword::Parser;
 use Moo;
 
-has target_package => (is => 'ro', required => 1);
+has parser => (is => 'ro', required => 1);
 
-has stash => (is => 'lazy');
+has parser_object => (is => 'lazy');
 
-sub _build_stash {
+sub _build_parser_object {
   my ($self) = @_;
-  Package::Stash::PP->new($self->target_package);
-}
-
-has keyword_name => (is => 'ro', required => 1);
-
-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) = @_;
-  warn "Save: ".$self->globref_refcount(svref_2object($self->globref)->REFCNT);
-}
-
-sub refcount_changed {
-  my ($self) = @_;
-  return 0 unless defined($self->globref_refcount);
-  svref_2object($self->globref)->REFCNT > $self->globref_refcount;
-}
-
-has info => (is => 'rw', predicate => 'has_info', clearer => 'clear_info');
-
-sub setup {
-  my ($self) = @_;
-  $self->globref;
-  filter_add($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 $name_re = '[A-Za-z][A-Za-z_0-9]*';
-
-sub filter {
+sub install {
   my ($self) = @_;
-  if ($self->has_info) {
-    if (delete $self->info->{first}) {
-      warn "Attempting short circuit";
-      filter_add($self);
-      return 0;
-    }
-    my $info = $self->clear_info;
-    $_ = $info->{rest};
-    if ($self->refcount_changed) {
-      warn "Trapped: ".$info->{name};
-      my $name = $info->{name};
-      ${$info->{inner}} = sub { warn "Define ${name}" };
-      #$self->clear_globref;
-      s/{/; sub ${\$info->{name}} { my \$self = shift;/;
-    }
-warn "Line: $_";
-    return 1;
-  }
-  my $status = filter_read();
-warn "Line: $_";
-  my $kw = $self->keyword_name;
-  if (/(.*?$kw\s+(${name_re}))(.*)\Z/s) {
-    my ($start, $name, $rest) = ($1, $2, $3);
-    $self->clear_globref if $self->refcount_changed;
-    no warnings 'redefine';
-    my $inner = sub {};
-    *{$self->globref} = sub (*;@) { $inner->(@_) };
-    $self->save_refcount;
-    $_ = $start;
-    $self->info({
-      name => $name, rest => $rest, first => 1,
-      inner => \$inner
-    });
-    return 1;
-  }
-  return $status;
+  my $parser = $self->parser_object;
+  filter_add(sub {
+    my ($string, $code) = $parser->get_next;
+    $_ = $string;
+    return $code;
+  });
 }
 
 1;
diff --git a/lib/Filter/Keyword/Parser.pm b/lib/Filter/Keyword/Parser.pm
new file mode 100644
index 0000000..6f4c8fb
--- /dev/null
+++ b/lib/Filter/Keyword/Parser.pm
@@ -0,0 +1,116 @@
+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);
+
+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');
+
+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;
+}
+
+has current_match => (is => 'rw');
+
+has short_circuit => (is => 'rw');
+
+has code => (is => 'rw', default => sub { '' });
+
+sub get_next {
+  my ($self) = @_;
+  if ($self->short_circuit) {
+    $self->short_circuit(0);
+    $self->${\$self->re_add};
+    return ('', 0);
+  }
+  if ($self->have_match) {
+    $self->clear_globref;
+    return $self->${\$self->parser};
+  }
+  return $self->check_match;
+}
+
+sub fetch_more {
+  my ($self) = @_;
+  my $code = $self->code||'';
+  my ($extra_code, $not_eof) = $self->${\$self->reader};
+  $code .= $extra_code;
+  $self->code($code);
+  return $not_eof;
+}
+
+sub match_source {
+  my ($self, $first, $second) = @_;
+  $self->fetch_more while $self->code =~ /$first\s+\Z/;
+  if (my @match = ($self->code =~ /(.*?${first}\s+${second})(.*)\Z/)) {
+    $self->code(pop @match);
+    my $found = shift(@match);
+    return ($found, \@match);
+  }
+  return;
+}
+
+sub check_match {
+  my ($self) = @_;
+  unless ($self->code) {
+    $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);
+  }
+  my $code = $self->code;
+  $self->code('');
+  return ($code, 1);
+}
+
+1;
diff --git a/t/simple.t b/t/simple.t
index edbef45..2c438d7 100644
--- a/t/simple.t
+++ b/t/simple.t
@@ -4,9 +4,21 @@ use Filter::Keyword;
 
 BEGIN {
   (our $Kw = Filter::Keyword->new(
-    target_package => __PACKAGE__,
-    keyword_name => 'method'
-  ))->setup;
+    parser => {
+      target_package => __PACKAGE__,
+      keyword_name => 'method',
+      parser => sub {
+        my $obj = shift;
+        if (my ($stripped, $matches) = $obj->match_source('', '{')) {
+          my $name = $obj->current_match->[0];
+          $stripped =~ s/{/; sub ${name} { my \$self = shift;/;
+          return ($stripped, 1);
+        } else {
+          return ('', 1);
+        }
+      }
+    },
+  ))->install;
 }
 
 method main { 'YAY '.$self };