lib/Filter/Keyword.pm

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