lib/Filter/Keyword.pm

   1 package Filter::Keyword;
   2
   3 use Package::Stash::PP;
   4 use Filter::Util::Call;
   5 use B qw(svref_2object);
   6 use Moo;
   7
   8 has target_package => (is => 'ro', required => 1);
   9
  10 has stash => (is => 'lazy');
  11
  12 sub _build_stash {
  13   my ($self) = @_;
  14   Package::Stash::PP->new($self->target_package);
  15 }
  16
  17 has keyword_name => (is => 'ro', required => 1);
  18
  19 has globref => (is => 'lazy', clearer => 'clear_globref');
  20
  21 sub _build_globref {
  22   no strict 'refs'; no warnings 'once';
  23   \*{join'::',$_[0]->target_package,$_[0]->keyword_name}
  24 }
  25
  26 after clear_globref => sub {
  27   my ($self) = @_;
  28   $self->stash->remove_symbol('&'.$self->keyword_name);
  29   $self->globref_refcount(undef);
  30 };
  31
  32 has globref_refcount => (is => 'rw');
  33
  34 sub save_refcount {
  35   my ($self) = @_;
  36   warn "Save: ".$self->globref_refcount(svref_2object($self->globref)->REFCNT);
  37 }
  38
  39 sub refcount_changed {
  40   my ($self) = @_;
  41   return 0 unless defined($self->globref_refcount);
  42   svref_2object($self->globref)->REFCNT > $self->globref_refcount;
  43 }
  44
  45 has info => (is => 'rw', predicate => 'has_info', clearer => 'clear_info');
  46
  47 sub setup {
  48   my ($self) = @_;
  49   $self->globref;
  50   filter_add($self);
  51 }
  52
  53 my $name_re = '[A-Za-z][A-Za-z_0-9]*';
  54
  55 sub filter {
  56   my ($self) = @_;
  57   if ($self->has_info) {
  58     if (delete $self->info->{first}) {
  59       warn "Attempting short circuit";
  60       filter_add($self);
  61       return 0;
  62     }
  63     my $info = $self->clear_info;
  64     $_ = $info->{rest};
  65     if ($self->refcount_changed) {
  66       warn "Trapped: ".$info->{name};
  67       my $name = $info->{name};
  68       ${$info->{inner}} = sub { warn "Define ${name}" };
  69       #$self->clear_globref;
  70       s/{/; sub ${\$info->{name}} { my \$self = shift;/;
  71     }
  72 warn "Line: $_";
  73     return 1;
  74   }
  75   my $status = filter_read();
  76 warn "Line: $_";
  77   my $kw = $self->keyword_name;
  78   if (/(.*?$kw\s+(${name_re}))(.*)\Z/s) {
  79     my ($start, $name, $rest) = ($1, $2, $3);
  80     $self->clear_globref if $self->refcount_changed;
  81     no warnings 'redefine';
  82     my $inner = sub {};
  83     *{$self->globref} = sub (*;@) { $inner->(@_) };
  84     $self->save_refcount;
  85     $_ = $start;
  86     $self->info({
  87       name => $name, rest => $rest, first => 1,
  88       inner => \$inner
  89     });
  90     return 1;
  91   }
  92   return $status;
  93 }
  94
  95 1;