Remove incorrect SKIP for 5.8.1
[p5sagit/namespace-clean.git] / lib / namespace / clean.pm
1 package namespace::clean;
2
3 use warnings;
4 use strict;
5
6 our $VERSION = '0.26';
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 $@;
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__
231
232 =head1 NAME
233
234 namespace::clean - Keep imports and functions out of your namespace
235
236 =head1 SYNOPSIS
237
238   package Foo;
239   use warnings;
240   use strict;
241
242   use Carp qw(croak);   # 'croak' will be removed
243
244   sub bar { 23 }        # 'bar' will be removed
245
246   # remove all previously defined functions
247   use namespace::clean;
248
249   sub baz { bar() }     # 'baz' still defined, 'bar' still bound
250
251   # begin to collection function names from here again
252   no namespace::clean;
253
254   sub quux { baz() }    # 'quux' will be removed
255
256   # remove all functions defined after the 'no' unimport
257   use namespace::clean;
258
259   # Will print: 'No', 'No', 'Yes' and 'No'
260   print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
261   print +(__PACKAGE__->can('bar')   ? 'Yes' : 'No'), "\n";
262   print +(__PACKAGE__->can('baz')   ? 'Yes' : 'No'), "\n";
263   print +(__PACKAGE__->can('quux')  ? 'Yes' : 'No'), "\n";
264
265   1;
266
267 =head1 DESCRIPTION
268
269 =head2 Keeping packages clean
270
271 When you define a function, or import one, into a Perl package, it will
272 naturally also be available as a method. This does not per se cause
273 problems, but it can complicate subclassing and, for example, plugin
274 classes that are included via multiple inheritance by loading them as
275 base classes.
276
277 The C<namespace::clean> pragma will remove all previously declared or
278 imported symbols at the end of the current package's compile cycle.
279 Functions called in the package itself will still be bound by their
280 name, but they won't show up as methods on your class or instances.
281
282 By unimporting via C<no> you can tell C<namespace::clean> to start
283 collecting functions for the next C<use namespace::clean;> specification.
284
285 You can use the C<-except> flag to tell C<namespace::clean> that you
286 don't want it to remove a certain function or method. A common use would
287 be a module exporting an C<import> method along with some functions:
288
289   use ModuleExportingImport;
290   use namespace::clean -except => [qw( import )];
291
292 If you just want to C<-except> a single sub, you can pass it directly.
293 For more than one value you have to use an array reference.
294
295 =head3 Late binding caveat
296
297 Note that the L<technique used by this module|/IMPLEMENTATION DETAILS> relies
298 on perl having resolved all names to actual code references during the
299 compilation of a scope. While this is almost always what the interpreter does,
300 there are some exceptions, notably the L<sort SUBNAME|perlfunc/sort> style of
301 the C<sort> built-in invocation. The following example will not work, because
302 C<sort> does not try to resolve the function name to an actual code reference
303 until B<runtime>.
304
305  use MyApp::Utils 'my_sorter';
306  use namespace::clean;
307
308  my @sorted = sort my_sorter @list;
309
310 You need to work around this by forcing a compile-time resolution like so:
311
312  use MyApp::Utils 'sorter';
313  use namespace::clean;
314
315  my $my_sorter_cref = \&sorter;
316
317  my @sorted = sort $my_sorter_cref @list;
318
319 =head2 Explicitly removing functions when your scope is compiled
320
321 It is also possible to explicitly tell C<namespace::clean> what packages
322 to remove when the surrounding scope has finished compiling. Here is an
323 example:
324
325   package Foo;
326   use strict;
327
328   # blessed NOT available
329
330   sub my_class {
331       use Scalar::Util qw( blessed );
332       use namespace::clean qw( blessed );
333
334       # blessed available
335       return blessed shift;
336   }
337
338   # blessed NOT available
339
340 =head2 Moose
341
342 When using C<namespace::clean> together with L<Moose> you want to keep
343 the installed C<meta> method. So your classes should look like:
344
345   package Foo;
346   use Moose;
347   use namespace::clean -except => 'meta';
348   ...
349
350 Same goes for L<Moose::Role>.
351
352 =head2 Cleaning other packages
353
354 You can tell C<namespace::clean> that you want to clean up another package
355 instead of the one importing. To do this you have to pass in the C<-cleanee>
356 option like this:
357
358   package My::MooseX::namespace::clean;
359   use strict;
360
361   use namespace::clean (); # no cleanup, just load
362
363   sub import {
364       namespace::clean->import(
365         -cleanee => scalar(caller),
366         -except  => 'meta',
367       );
368   }
369
370 If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
371 just want to remove subroutines, try L</clean_subroutines>.
372
373 =head1 METHODS
374
375 =head2 clean_subroutines
376
377 This exposes the actual subroutine-removal logic.
378
379   namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
380
381 will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
382 subroutines B<immediately> and not wait for scope end. If you want to have this
383 effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
384 it is your responsibility to make sure it runs at that time.
385
386 =head2 import
387
388 Makes a snapshot of the current defined functions and installs a
389 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
390
391
392 =head2 unimport
393
394 This method will be called when you do a
395
396   no namespace::clean;
397
398 It will start a new section of code that defines functions to clean up.
399
400 =head2 get_class_store
401
402 This returns a reference to a hash in a passed package containing
403 information about function names included and excluded from removal.
404
405 =head2 get_functions
406
407 Takes a class as argument and returns all currently defined functions
408 in it as a hash reference with the function name as key and a typeglob
409 reference to the symbol as value.
410
411 =head1 IMPLEMENTATION DETAILS
412
413 This module works through the effect that a
414
415   delete $SomePackage::{foo};
416
417 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
418 (e.g., method calls) but will leave the entry alive to be called by
419 already resolved names in the package itself. C<namespace::clean> will
420 restore and therefor in effect keep all glob slots that aren't C<CODE>.
421
422 A test file has been added to the perl core to ensure that this behaviour
423 will be stable in future releases.
424
425 Just for completeness sake, if you want to remove the symbol completely,
426 use C<undef> instead.
427
428 =head1 SEE ALSO
429
430 L<B::Hooks::EndOfScope>
431
432 =head1 THANKS
433
434 Many thanks to Matt S Trout for the inspiration on the whole idea.
435
436 =head1 AUTHORS
437
438 =over
439
440 =item *
441
442 Robert 'phaylon' Sedlacek <rs@474.at>
443
444 =item *
445
446 Florian Ragwitz <rafl@debian.org>
447
448 =item *
449
450 Jesse Luehrs <doy@tozt.net>
451
452 =item *
453
454 Peter Rabbitson <ribasushi@cpan.org>
455
456 =item *
457
458 Father Chrysostomos <sprout@cpan.org>
459
460 =back
461
462 =head1 COPYRIGHT AND LICENSE
463
464 This software is copyright (c) 2011 by L</AUTHORS>
465
466 This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.