lib/Filter/Keyword.pm

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