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 => (is => 'rw', weak_ref => 1, clearer => 1);
  57
  58 has target_package => (is => 'ro', required => 1);
  59 has keyword_name   => (is => 'ro', required => 1);
  60 has parser         => (is => 'ro', required => 1);
  61
  62 has stash => (is => 'lazy');
  63
  64 sub _build_stash {
  65   my ($self) = @_;
  66   Package::Stash::PP->new($self->target_package);
  67 }
  68
  69 has globref => (is => 'lazy', clearer => 'clear_globref');
  70
  71 sub _build_globref {
  72   no strict 'refs'; no warnings 'once';
  73   \*{join'::',$_[0]->target_package,$_[0]->keyword_name}
  74 }
  75
  76 after clear_globref => sub {
  77   my ($self) = @_;
  78   $self->stash->remove_symbol('&'.$self->keyword_name);
  79   $self->globref_refcount(undef);
  80 };
  81
  82 has globref_refcount => (is => 'rw');
  83
  84 sub save_refcount {
  85   my ($self) = @_;
  86   $self->globref_refcount(svref_2object($self->globref)->REFCNT);
  87 }
  88
  89 sub have_match {
  90   my ($self) = @_;
  91   return 0 unless defined($self->globref_refcount);
  92   svref_2object($self->globref)->REFCNT > $self->globref_refcount;
  93 }
  94
  95 sub DEMOLISH {
  96   my ($self) = @_;
  97   $self->remove;
  98 }
  99
 100 1;