Filename | /usr/local/lib/perl5/site_perl/namespace/clean.pm |
Statements | Executed 0 statements in 0s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | BEGIN@11 | namespace::clean::
0 | 0 | 0 | 0s | 0s | BEGIN@16 | namespace::clean::
0 | 0 | 0 | 0s | 0s | BEGIN@3 | namespace::clean::
0 | 0 | 0 | 0s | 0s | BEGIN@38 | namespace::clean::
0 | 0 | 0 | 0s | 0s | BEGIN@4 | namespace::clean::
0 | 0 | 0 | 0s | 0s | CORE:match (opcode) | namespace::clean::
0 | 0 | 0 | 0s | 0s | __ANON__[:130] | namespace::clean::
0 | 0 | 0 | 0s | 0s | __ANON__[:160] | namespace::clean::
0 | 0 | 0 | 0s | 0s | __ANON__[:185] | namespace::clean::
0 | 0 | 0 | 0s | 0s | clean_subroutines | namespace::clean::
0 | 0 | 0 | 0s | 0s | get_class_store | namespace::clean::
0 | 0 | 0 | 0s | 0s | get_functions | namespace::clean::
0 | 0 | 0 | 0s | 0s | import | namespace::clean::
0 | 0 | 0 | 0s | 0s | unimport | namespace::clean::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package namespace::clean; | ||||
2 | |||||
3 | use warnings; | ||||
4 | use strict; | ||||
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 | use B::Hooks::EndOfScope 'on_scope_end'; | ||||
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 | my $provider; | ||||
18 | |||||
19 | if ( "$]" < 5.008007 ) { | ||||
20 | require Package::Stash::PP; | ||||
21 | $provider = 'Package::Stash::PP'; | ||||
22 | } | ||||
23 | else { | ||||
24 | require Package::Stash; | ||||
25 | $provider = 'Package::Stash'; | ||||
26 | } | ||||
27 | eval <<"EOS" or die $@; # spent 0s executing statements in string eval | ||||
28 | |||||
29 | sub stash_for (\$) { | ||||
30 | $provider->new(\$_[0]); | ||||
31 | } | ||||
32 | |||||
33 | 1; | ||||
34 | |||||
35 | EOS | ||||
36 | } | ||||
37 | |||||
38 | use namespace::clean::_Util qw( DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT ); | ||||
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 | my ($nc, $cleanee, @subs) = @_; | ||||
134 | $RemoveSubs->($cleanee, {}, @subs); | ||||
135 | } | ||||
136 | |||||
137 | sub import { | ||||
138 | my ($pragma, @args) = @_; | ||||
139 | |||||
140 | my (%args, $is_explicit); | ||||
141 | |||||
142 | ARG: | ||||
143 | while (@args) { | ||||
144 | |||||
145 | if ($args[0] =~ /^\-/) { | ||||
146 | my $key = shift @args; | ||||
147 | my $value = shift @args; | ||||
148 | $args{ $key } = $value; | ||||
149 | } | ||||
150 | else { | ||||
151 | $is_explicit++; | ||||
152 | last ARG; | ||||
153 | } | ||||
154 | } | ||||
155 | |||||
156 | my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller; | ||||
157 | if ($is_explicit) { | ||||
158 | on_scope_end { | ||||
159 | $RemoveSubs->($cleanee, {}, @args); | ||||
160 | }; | ||||
161 | } | ||||
162 | else { | ||||
163 | |||||
164 | # calling class, all current functions and our storage | ||||
165 | my $functions = $pragma->get_functions($cleanee); | ||||
166 | my $store = $pragma->get_class_store($cleanee); | ||||
167 | my $stash = stash_for($cleanee); | ||||
168 | |||||
169 | # except parameter can be array ref or single value | ||||
170 | my %except = map {( $_ => 1 )} ( | ||||
171 | $args{ -except } | ||||
172 | ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } ) | ||||
173 | : () | ||||
174 | ); | ||||
175 | |||||
176 | # register symbols for removal, if they have a CODE entry | ||||
177 | for my $f (keys %$functions) { | ||||
178 | next if $except{ $f }; | ||||
179 | next unless $stash->has_symbol("&$f"); | ||||
180 | $store->{remove}{ $f } = 1; | ||||
181 | } | ||||
182 | |||||
183 | on_scope_end { | ||||
184 | $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} }); | ||||
185 | }; | ||||
186 | |||||
187 | return 1; | ||||
188 | } | ||||
189 | } | ||||
190 | |||||
191 | sub unimport { | ||||
192 | my ($pragma, %args) = @_; | ||||
193 | |||||
194 | # the calling class, the current functions and our storage | ||||
195 | my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller; | ||||
196 | my $functions = $pragma->get_functions($cleanee); | ||||
197 | my $store = $pragma->get_class_store($cleanee); | ||||
198 | |||||
199 | # register all unknown previous functions as excluded | ||||
200 | for my $f (keys %$functions) { | ||||
201 | next if $store->{remove}{ $f } | ||||
202 | or $store->{exclude}{ $f }; | ||||
203 | $store->{exclude}{ $f } = 1; | ||||
204 | } | ||||
205 | |||||
206 | return 1; | ||||
207 | } | ||||
208 | |||||
209 | sub get_class_store { | ||||
210 | my ($pragma, $class) = @_; | ||||
211 | my $stash = stash_for($class); | ||||
212 | my $var = "%$STORAGE_VAR"; | ||||
213 | $stash->add_symbol($var, {}) | ||||
214 | unless $stash->has_symbol($var); | ||||
215 | return $stash->get_symbol($var); | ||||
216 | } | ||||
217 | |||||
218 | sub get_functions { | ||||
219 | my ($pragma, $class) = @_; | ||||
220 | |||||
221 | my $stash = stash_for($class); | ||||
222 | return { | ||||
223 | map { $_ => $stash->get_symbol("&$_") } | ||||
224 | $stash->list_all_symbols('CODE') | ||||
225 | }; | ||||
226 | } | ||||
227 | |||||
228 | 'Danger! Laws of Thermodynamics may not apply.' | ||||
229 | |||||
230 | __END__ |