lib/Filter/Keyword.pm

   1 package Filter::Keyword;
   2 use Moo;
   3
   4 use Filter::Keyword::Filter;
   5 use Filter::Util::Call;
   6 use Scalar::Util qw(weaken);
   7 use Package::Stash::PP;
   8 use B qw(svref_2object);
   9 use B::Hooks::EndOfScope;
  10 use Scalar::Util qw(set_prototype);
  11
  12 sub _compiling_file () {
  13   my $depth = 0;
  14   while (my @caller = caller(++$depth)) {
  15     if ($caller[3] =~ /::BEGIN$/) {
  16       # older perls report the BEGIN in the wrong file
  17       return $depth > 1 ? (caller($depth-1))[1] : $caller[1];
  18       #return $caller[1];
  19     }
  20   }
  21   die;
  22 }
  23
  24 my %filters;
  25 sub install {
  26   my ($self) = @_;
  27   $self->shadow_sub;
  28
  29   my $file = _compiling_file;
  30   my $filter = $filters{$file} ||= Filter::Keyword::Filter->new;
  31   $filter->install;
  32
  33   my $parser = $filter->parser;
  34   $parser->add_keyword($self);
  35   $self->keyword_parser($parser);
  36
  37   on_scope_end {
  38     $self->remove;
  39   };
  40 }
  41
  42 has _shadowed_sub => (is => 'rw', clearer => 1);
  43
  44 sub shadow_sub {
  45   my $self = shift;
  46   my $stash = $self->stash;
  47   if (my $shadowed = $stash->get_symbol('&'.$self->keyword_name)) {
  48     $self->_shadowed_sub($shadowed);
  49     $stash->remove_symbol('&'.$self->keyword_name);
  50   }
  51 }
  52
  53 sub remove {
  54   my ($self) = @_;
  55   $self->keyword_parser->remove_keyword($self);
  56   $self->clear_keyword_parser;
  57   $self->clear_globref;
  58   my $stash = $self->stash;
  59   if (my $shadowed = $self->_shadowed_sub) {
  60     $self->_clear_shadowed_sub;
  61     $stash->add_symbol('&'.$self->keyword_name, $shadowed);
  62   }
  63 }
  64
  65 has keyword_parser => (
  66   is => 'rw',
  67   weak_ref => 1,
  68   clearer => 1,
  69   handles => [
  70     'match_source',
  71     'current_match',
  72   ],
  73 );
  74
  75 has target_package => (is => 'ro', required => 1);
  76 has keyword_name   => (is => 'ro', required => 1);
  77 has parser         => (is => 'ro', required => 1);
  78
  79 sub parse {
  80   my $self = shift;
  81   $self->${\$self->parser}(@_);
  82 }
  83
  84 has stash => (is => 'lazy');
  85
  86 sub _build_stash {
  87   my ($self) = @_;
  88   Package::Stash::PP->new($self->target_package);
  89 }
  90
  91 has globref => (is => 'lazy', clearer => 'clear_globref');
  92
  93 sub _build_globref {
  94   no strict 'refs'; no warnings 'once';
  95   \*{join'::',$_[0]->target_package,$_[0]->keyword_name}
  96 }
  97
  98 after clear_globref => sub {
  99   my ($self) = @_;
 100   $self->stash->remove_symbol('&'.$self->keyword_name);
 101   $self->globref_refcount(undef);
 102   $self->restore_shadow;
 103 };
 104
 105 sub restore_shadow {
 106   my ($self) = @_;
 107   if (my $shadowed = $self->_shadowed_sub) {
 108     { no warnings 'redefine', 'prototype'; *{$self->globref} = $shadowed; }
 109   }
 110 }
 111
 112 has globref_refcount => (is => 'rw');
 113
 114 sub save_refcount {
 115   my ($self) = @_;
 116   $self->globref_refcount(svref_2object($self->globref)->REFCNT);
 117 }
 118
 119 sub install_matcher {
 120   my ($self, $post) = @_;
 121   my $stash = $self->stash;
 122   my $sub = sub {};
 123   set_prototype(\&$sub, '*;@') unless $post eq '(';
 124   { no warnings 'redefine', 'prototype'; *{$self->globref} = $sub; }
 125   $self->save_refcount;
 126 }
 127
 128 sub have_match {
 129   my ($self) = @_;
 130   return 0 unless defined($self->globref_refcount);
 131   svref_2object($self->globref)->REFCNT > $self->globref_refcount;
 132 }
 133
 134 sub inject_after_scope {
 135   my $inject = shift;
 136   on_scope_end {
 137     filter_add(sub {
 138       my($status) ;
 139       $status = filter_read();
 140       if ($status >= 0) {
 141         $_ = $inject . $_;
 142       }
 143       filter_del();
 144       $status ;
 145     });
 146   };
 147 }
 148
 149 1;