File Coverage

blib/lib/namespace/clean.pm
Criterion Covered Total %
statement 64 66 96.9
branch 20 24 83.3
condition 2 3 66.6
subroutine 13 13 100.0
pod 3 4 75.0
total 102 110 92.7


line stmt bran cond sub pod time code
1             package namespace::clean;
2              
3 13     13   111710 use warnings;
  13         18  
  13         371  
4 13     13   42 use strict;
  13         13  
  13         818  
5              
6             our $VERSION = '0.27';
7             $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
8              
9             our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
10              
11 13     13   5155 use B::Hooks::EndOfScope 'on_scope_end';
  13         105518  
  13         74  
12              
13             # FIXME This is a crock of shit, needs to go away
14             # currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151
15             # kill with fire when PS::XS is *finally* fixed
16             BEGIN {
17 13     13   1596 my $provider;
18              
19 13 50       70 if ( "$]" < 5.008007 ) {
20 0         0 require Package::Stash::PP;
21 0         0 $provider = 'Package::Stash::PP';
22             }
23             else {
24 13         5249 require Package::Stash;
25 13         15553 $provider = 'Package::Stash';
26             }
27 13 50   1110 0 903 eval <<"EOS" or die $@;
  1110         8784  
28              
29             sub stash_for (\$) {
30             $provider->new(\$_[0]);
31             }
32              
33             1;
34              
35             EOS
36             }
37              
38 13     13   4357 use namespace::clean::_Util qw( DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT );
  13         25  
  13         10206  
39              
40             # Built-in debugger CV-retrieval fixups necessary before perl 5.15.5:
41             # since we are deleting the glob where the subroutine was originally
42             # defined, the assumptions below no longer hold.
43             #
44             # In 5.8.9 ~ 5.13.5 (inclusive) the debugger assumes that a CV can
45             # always be found under sub_fullname($sub)
46             # Workaround: use sub naming to properly name the sub hidden in the package's
47             # deleted-stash
48             #
49             # In the rest of the range ( ... ~ 5.8.8 and 5.13.6 ~ 5.15.4 ) the debugger
50             # assumes the name of the glob passed to entersub can be used to find the CV
51             # Workaround: realias the original glob to the deleted-stash slot
52             #
53             # While the errors manifest themselves inside perl5db.pl, they are caused by
54             # problems inside the interpreter. If enabled ($^P & 0x01) and existent,
55             # the DB::sub sub will be called by the interpreter for any sub call rather
56             # that call the sub directly. It is provided the real sub to call in $DB::sub,
57             # but the value given has the issues described above. We only have to enable
58             # the workaround if DB::sub will be used.
59             #
60             # Can not tie constants to the current value of $^P directly,
61             # as the debugger can be enabled during runtime (kinda dubious)
62             #
63              
64             my $RemoveSubs = sub {
65             my $cleanee = shift;
66             my $store = shift;
67             my $cleanee_stash = stash_for($cleanee);
68             my $deleted_stash;
69              
70             SYMBOL:
71             for my $f (@_) {
72              
73             # ignore already removed symbols
74             next SYMBOL if $store->{exclude}{ $f };
75              
76             my $sub = $cleanee_stash->get_symbol("&$f")
77             or next SYMBOL;
78              
79             my $need_debugger_fixup =
80             ( DEBUGGER_NEEDS_CV_RENAME or DEBUGGER_NEEDS_CV_PIVOT )
81             &&
82             $^P & 0x01
83             &&
84             defined &DB::sub
85             &&
86             ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
87             &&
88             ( $deleted_stash ||= stash_for("namespace::clean::deleted::$cleanee") )
89             ;
90              
91             # convince the Perl debugger to work
92             # see the comment on top
93             if ( DEBUGGER_NEEDS_CV_RENAME and $need_debugger_fixup ) {
94             #
95             # Note - both get_subname and set_subname are only compiled when CV_RENAME
96             # is true ( the 5.8.9 ~ 5.12 range ). On other perls this entire block is
97             # constant folded away, and so are the definitions in ::_Util
98             #
99             # Do not be surprised that they are missing without DEBUGGER_NEEDS_CV_RENAME
100             #
101             namespace::clean::_Util::get_subname( $sub ) eq ( $cleanee_stash->name . "::$f" )
102             and
103             $deleted_stash->add_symbol(
104             "&$f",
105             namespace::clean::_Util::set_subname( $deleted_stash->name . "::$f", $sub ),
106             );
107             }
108             elsif ( DEBUGGER_NEEDS_CV_PIVOT and $need_debugger_fixup ) {
109             $deleted_stash->add_symbol("&$f", $sub);
110             }
111              
112             my @symbols = map {
113             my $name = $_ . $f;
114             my $def = $cleanee_stash->get_symbol($name);
115             defined($def) ? [$name, $def] : ()
116             } '$', '@', '%', '';
117              
118             $cleanee_stash->remove_glob($f);
119              
120             # if this perl needs no renaming trick we need to
121             # rename the original glob after the fact
122             DEBUGGER_NEEDS_CV_PIVOT
123             and
124             $need_debugger_fixup
125             and
126             *$globref = $deleted_stash->namespace->{$f};
127              
128             $cleanee_stash->add_symbol(@$_) for @symbols;
129             }
130             };
131              
132             sub clean_subroutines {
133 1     1 1 323 my ($nc, $cleanee, @subs) = @_;
134 1         3 $RemoveSubs->($cleanee, {}, @subs);
135             }
136              
137             sub import {
138 1026     1026   751828 my ($pragma, @args) = @_;
139              
140 1026         1065 my (%args, $is_explicit);
141              
142             ARG:
143 1026         2035 while (@args) {
144              
145 2007 100       4507 if ($args[0] =~ /^\-/) {
146 1006         1070 my $key = shift @args;
147 1006         844 my $value = shift @args;
148 1006         2372 $args{ $key } = $value;
149             }
150             else {
151 1001         838 $is_explicit++;
152 1001         1164 last ARG;
153             }
154             }
155              
156 1026 100       2202 my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
157 1026 100       1171 if ($is_explicit) {
158             on_scope_end {
159 1001     1001   31986 $RemoveSubs->($cleanee, {}, @args);
160 1001         4463 };
161             }
162             else {
163              
164             # calling class, all current functions and our storage
165 25         41 my $functions = $pragma->get_functions($cleanee);
166 25         72 my $store = $pragma->get_class_store($cleanee);
167 25         497 my $stash = stash_for($cleanee);
168              
169             # except parameter can be array ref or single value
170 5         12 my %except = map {( $_ => 1 )} (
171             $args{ -except }
172 2         4 ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
173 25 100       100 : ()
    100          
174             );
175              
176             # register symbols for removal, if they have a CODE entry
177 25         71 for my $f (keys %$functions) {
178 96 100       139 next if $except{ $f };
179 91 50       309 next unless $stash->has_symbol("&$f");
180 91         141 $store->{remove}{ $f } = 1;
181             }
182              
183             on_scope_end {
184 25     25   6735 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
  25         90  
185 25         125 };
186              
187 25         1130 return 1;
188             }
189             }
190              
191             sub unimport {
192 4     4   18 my ($pragma, %args) = @_;
193              
194             # the calling class, the current functions and our storage
195 4 50       16 my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
196 4         6 my $functions = $pragma->get_functions($cleanee);
197 4         9 my $store = $pragma->get_class_store($cleanee);
198              
199             # register all unknown previous functions as excluded
200 4         12 for my $f (keys %$functions) {
201             next if $store->{remove}{ $f }
202 9 100 66     28 or $store->{exclude}{ $f };
203 4         6 $store->{exclude}{ $f } = 1;
204             }
205              
206 4         149 return 1;
207             }
208              
209             sub get_class_store {
210 29     29 1 38 my ($pragma, $class) = @_;
211 29         545 my $stash = stash_for($class);
212 29         48 my $var = "%$STORAGE_VAR";
213 29 100       238 $stash->add_symbol($var, {})
214             unless $stash->has_symbol($var);
215 29         121 return $stash->get_symbol($var);
216             }
217              
218             sub get_functions {
219 29     29 1 32 my ($pragma, $class) = @_;
220              
221 29         609 my $stash = stash_for($class);
222             return {
223 29         292 map { $_ => $stash->get_symbol("&$_") }
  105         494  
224             $stash->list_all_symbols('CODE')
225             };
226             }
227              
228             'Danger! Laws of Thermodynamics may not apply.'
229              
230             __END__