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
   9 sub _compiling_file () {
  10   my $depth = 0;
  11   while (my @caller = caller(++$depth)) {
  12     if ($caller[3] =~ /::BEGIN$/) {
  13       # older perls report the BEGIN in the wrong file
  14       return $depth > 1 ? (caller($depth-1))[1] : $caller[1];
  15       #return $caller[1];
  16     }
  17   }
  18   die;
  19 }
  20
  21 my %filters;
  22 sub install {
  23   my ($self) = @_;
  24   my $file = _compiling_file;
  25   $self->shadow_sub;
  26   my $filter = $filters{$file} ||= Filter::Keyword::Filter->new;
  27   $filter->install;
  28   my $parser = $filter->parser;
  29   $parser->add_keyword($self);
  30   $self->keyword_parser($parser);
  31 }
  32
  33 sub shadow_sub {
  34   my $self = shift;
  35   my $stash = $self->stash;
  36   if (my $shadowed = $stash->get_symbol('&'.$self->keyword_name)) {
  37     $stash->remove_symbol('&'.$self->keyword_name);
  38     $stash->add_symbol('&__'.$self->keyword_name, $shadowed);
  39   }
  40 }
  41
  42 sub remove {
  43   my ($self) = @_;
  44   $self->keyword_parser->remove_keyword($self);
  45   $self->clear_keyword_parser;
  46   $self->clear_globref;
  47 }
  48
  49 has keyword_parser => (is => 'rw', weak_ref => 1, clearer => 1);
  50
  51 has target_package => (is => 'ro', required => 1);
  52 has keyword_name   => (is => 'ro', required => 1);
  53 has parser         => (is => 'ro', required => 1);
  54
  55 has stash => (is => 'lazy');
  56
  57 sub _build_stash {
  58   my ($self) = @_;
  59   Package::Stash::PP->new($self->target_package);
  60 }
  61
  62 has globref => (is => 'lazy', clearer => 'clear_globref');
  63
  64 sub _build_globref {
  65   no strict 'refs'; no warnings 'once';
  66   \*{join'::',$_[0]->target_package,$_[0]->keyword_name}
  67 }
  68
  69 after clear_globref => sub {
  70   my ($self) = @_;
  71   $self->stash->remove_symbol('&'.$self->keyword_name);
  72   $self->globref_refcount(undef);
  73 };
  74
  75 has globref_refcount => (is => 'rw');
  76
  77 sub save_refcount {
  78   my ($self) = @_;
  79   $self->globref_refcount(svref_2object($self->globref)->REFCNT);
  80 }
  81
  82 sub have_match {
  83   my ($self) = @_;
  84   return 0 unless defined($self->globref_refcount);
  85   svref_2object($self->globref)->REFCNT > $self->globref_refcount;
  86 }
  87
  88 sub DEMOLISH {
  89   my ($self) = @_;
  90   $self->remove;
  91 }
  92
  93 1;