Commit | Line | Data |
3b08744b |
1 | package Filter::Keyword; |
2 | |
da378187 |
3 | # we need the PP implementation's version of remove_symbol |
3b08744b |
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; |