lib/namespace/clean.pm

   1 package namespace::clean;
   2 # ABSTRACT: Keep imports and functions out of your namespace
   3
   4 use warnings;
   5 use strict;
   6
   7 use vars qw( $STORAGE_VAR );
   8 use Package::Stash;
   9
  10 our $VERSION = '0.20_01';
  11
  12 $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
  13
  14 BEGIN {
  15
  16   use warnings;
  17   use strict;
  18
  19   # when changing also change in Makefile.PL
  20   my $b_h_eos_req = '0.07';
  21
  22   if (eval {
  23     require B::Hooks::EndOfScope;
  24     B::Hooks::EndOfScope->VERSION($b_h_eos_req);
  25     1
  26   } ) {
  27     B::Hooks::EndOfScope->import('on_scope_end');
  28   }
  29   else {
  30     eval <<'PP' or die $@;
  31
  32   use Tie::Hash ();
  33
  34   {
  35     package namespace::clean::_TieHintHash;
  36
  37     use warnings;
  38     use strict;
  39
  40     use base 'Tie::ExtraHash';
  41   }
  42
  43   {
  44     package namespace::clean::_ScopeGuard;
  45
  46     use warnings;
  47     use strict;
  48
  49     sub arm { bless [ $_[1] ] }
  50
  51     sub DESTROY { $_[0]->[0]->() }
  52   }
  53
  54
  55   sub on_scope_end (&) {
  56     $^H |= 0x020000;
  57
  58     if( my $stack = tied( %^H ) ) {
  59       if ( (my $c = ref $stack) ne 'namespace::clean::_TieHintHash') {
  60         die <<EOE;
  61 ========================================================================
  62                !!!   F A T A L   E R R O R   !!!
  63
  64                  foreign tie() of %^H detected
  65 ========================================================================
  66
  67 namespace::clean is currently operating in pure-perl fallback mode, because
  68 your system is lacking the necessary dependency B::Hooks::EndOfScope $b_h_eos_req.
  69 In this mode namespace::clean expects to be able to tie() the hinthash %^H,
  70 however it is apparently already tied by means unknown to the tie-class
  71 $c
  72
  73 Since this is a no-win situation execution will abort here and now. Please
  74 try to find out which other module is relying on hinthash tie() ability,
  75 and file a bug for both the perpetrator and namespace::clean, so that the
  76 authors can figure out an acceptable way of moving forward.
  77
  78 EOE
  79       }
  80       push @$stack, namespace::clean::_ScopeGuard->arm(shift);
  81     }
  82     else {
  83       tie( %^H, 'namespace::clean::_TieHintHash', namespace::clean::_ScopeGuard->arm(shift) );
  84     }
  85   }
  86
  87   1;
  88
  89 PP
  90
  91   }
  92 }
  93
  94 =head1 SYNOPSIS
  95
  96   package Foo;
  97   use warnings;
  98   use strict;
  99
 100   use Carp qw(croak);   # 'croak' will be removed
 101
 102   sub bar { 23 }        # 'bar' will be removed
 103
 104   # remove all previously defined functions
 105   use namespace::clean;
 106
 107   sub baz { bar() }     # 'baz' still defined, 'bar' still bound
 108
 109   # begin to collection function names from here again
 110   no namespace::clean;
 111
 112   sub quux { baz() }    # 'quux' will be removed
 113
 114   # remove all functions defined after the 'no' unimport
 115   use namespace::clean;
 116
 117   # Will print: 'No', 'No', 'Yes' and 'No'
 118   print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
 119   print +(__PACKAGE__->can('bar')   ? 'Yes' : 'No'), "\n";
 120   print +(__PACKAGE__->can('baz')   ? 'Yes' : 'No'), "\n";
 121   print +(__PACKAGE__->can('quux')  ? 'Yes' : 'No'), "\n";
 122
 123   1;
 124
 125 =head1 DESCRIPTION
 126
 127 =head2 Keeping packages clean
 128
 129 When you define a function, or import one, into a Perl package, it will
 130 naturally also be available as a method. This does not per se cause
 131 problems, but it can complicate subclassing and, for example, plugin
 132 classes that are included via multiple inheritance by loading them as
 133 base classes.
 134
 135 The C<namespace::clean> pragma will remove all previously declared or
 136 imported symbols at the end of the current package's compile cycle.
 137 Functions called in the package itself will still be bound by their
 138 name, but they won't show up as methods on your class or instances.
 139
 140 By unimporting via C<no> you can tell C<namespace::clean> to start
 141 collecting functions for the next C<use namespace::clean;> specification.
 142
 143 You can use the C<-except> flag to tell C<namespace::clean> that you
 144 don't want it to remove a certain function or method. A common use would
 145 be a module exporting an C<import> method along with some functions:
 146
 147   use ModuleExportingImport;
 148   use namespace::clean -except => [qw( import )];
 149
 150 If you just want to C<-except> a single sub, you can pass it directly.
 151 For more than one value you have to use an array reference.
 152
 153 =head2 Explicitly removing functions when your scope is compiled
 154
 155 It is also possible to explicitly tell C<namespace::clean> what packages
 156 to remove when the surrounding scope has finished compiling. Here is an
 157 example:
 158
 159   package Foo;
 160   use strict;
 161
 162   # blessed NOT available
 163
 164   sub my_class {
 165       use Scalar::Util qw( blessed );
 166       use namespace::clean qw( blessed );
 167
 168       # blessed available
 169       return blessed shift;
 170   }
 171
 172   # blessed NOT available
 173
 174 =head2 Moose
 175
 176 When using C<namespace::clean> together with L<Moose> you want to keep
 177 the installed C<meta> method. So your classes should look like:
 178
 179   package Foo;
 180   use Moose;
 181   use namespace::clean -except => 'meta';
 182   ...
 183
 184 Same goes for L<Moose::Role>.
 185
 186 =head2 Cleaning other packages
 187
 188 You can tell C<namespace::clean> that you want to clean up another package
 189 instead of the one importing. To do this you have to pass in the C<-cleanee>
 190 option like this:
 191
 192   package My::MooseX::namespace::clean;
 193   use strict;
 194
 195   use namespace::clean (); # no cleanup, just load
 196
 197   sub import {
 198       namespace::clean->import(
 199         -cleanee => scalar(caller),
 200         -except  => 'meta',
 201       );
 202   }
 203
 204 If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
 205 just want to remove subroutines, try L</clean_subroutines>.
 206
 207 =head1 METHODS
 208
 209 =head2 clean_subroutines
 210
 211 This exposes the actual subroutine-removal logic.
 212
 213   namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
 214
 215 will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
 216 subroutines B<immediately> and not wait for scope end. If you want to have this
 217 effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
 218 it is your responsibility to make sure it runs at that time.
 219
 220 =cut
 221
 222 my $sub_utils_loaded;
 223 my $DebuggerRename = sub {
 224   my ($f, $sub, $cleanee_stash, $deleted_stash) = @_;
 225
 226   if (! defined $sub_utils_loaded ) {
 227     $sub_utils_loaded = do {
 228       my $sn_ver = 0.04;
 229       eval { require Sub::Name; Sub::Name->VERSION($sn_ver) }
 230         or die "Sub::Name $sn_ver required when running under -d or equivalent: $@";
 231
 232       my $si_ver = 0.04;
 233       eval { require Sub::Identify; Sub::Identify->VERSION($si_ver) }
 234         or die "Sub::Identify $si_ver required when running under -d or equivalent: $@";
 235
 236       1;
 237     } ? 1 : 0;
 238   }
 239
 240   if ( Sub::Identify::sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
 241     my $new_fq = $deleted_stash->name . "::$f";
 242     Sub::Name::subname($new_fq, $sub);
 243     $deleted_stash->add_symbol("&$f", $sub);
 244   }
 245 };
 246
 247 my $RemoveSubs = sub {
 248     my $cleanee = shift;
 249     my $store   = shift;
 250     my $cleanee_stash = Package::Stash->new($cleanee);
 251     my $deleted_stash;
 252
 253   SYMBOL:
 254     for my $f (@_) {
 255
 256         # ignore already removed symbols
 257         next SYMBOL if $store->{exclude}{ $f };
 258
 259         my $sub = $cleanee_stash->get_symbol("&$f")
 260           or next SYMBOL;
 261
 262         if ($^P and ref(\$cleanee_stash->namespace->{$f}) eq 'GLOB') {
 263             # convince the Perl debugger to work
 264             # it assumes that sub_fullname($sub) can always be used to find the CV again
 265             # since we are deleting the glob where the subroutine was originally
 266             # defined, that assumption no longer holds, so we need to move it
 267             # elsewhere and point the CV's name to the new glob.
 268             $DebuggerRename->(
 269               $f,
 270               $sub,
 271               $cleanee_stash,
 272               $deleted_stash ||= Package::Stash->new("namespace::clean::deleted::$cleanee"),
 273             );
 274         }
 275
 276         my @symbols = map {
 277             my $name = $_ . $f;
 278             my $def = $cleanee_stash->get_symbol($name);
 279             defined($def) ? [$name, $def] : ()
 280         } '$', '@', '%', '';
 281
 282         $cleanee_stash->remove_glob($f);
 283
 284         $cleanee_stash->add_symbol(@$_) for @symbols;
 285     }
 286 };
 287
 288 sub clean_subroutines {
 289     my ($nc, $cleanee, @subs) = @_;
 290     $RemoveSubs->($cleanee, {}, @subs);
 291 }
 292
 293 =head2 import
 294
 295 Makes a snapshot of the current defined functions and installs a
 296 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 297
 298 =cut
 299
 300 sub import {
 301     my ($pragma, @args) = @_;
 302
 303     my (%args, $is_explicit);
 304
 305   ARG:
 306     while (@args) {
 307
 308         if ($args[0] =~ /^\-/) {
 309             my $key = shift @args;
 310             my $value = shift @args;
 311             $args{ $key } = $value;
 312         }
 313         else {
 314             $is_explicit++;
 315             last ARG;
 316         }
 317     }
 318
 319     my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 320     if ($is_explicit) {
 321         on_scope_end {
 322             $RemoveSubs->($cleanee, {}, @args);
 323         };
 324     }
 325     else {
 326
 327         # calling class, all current functions and our storage
 328         my $functions = $pragma->get_functions($cleanee);
 329         my $store     = $pragma->get_class_store($cleanee);
 330         my $stash     = Package::Stash->new($cleanee);
 331
 332         # except parameter can be array ref or single value
 333         my %except = map {( $_ => 1 )} (
 334             $args{ -except }
 335             ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
 336             : ()
 337         );
 338
 339         # register symbols for removal, if they have a CODE entry
 340         for my $f (keys %$functions) {
 341             next if     $except{ $f };
 342             next unless $stash->has_symbol("&$f");
 343             $store->{remove}{ $f } = 1;
 344         }
 345
 346         # register EOF handler on first call to import
 347         unless ($store->{handler_is_installed}) {
 348             on_scope_end {
 349                 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 350             };
 351             $store->{handler_is_installed} = 1;
 352         }
 353
 354         return 1;
 355     }
 356 }
 357
 358 =head2 unimport
 359
 360 This method will be called when you do a
 361
 362   no namespace::clean;
 363
 364 It will start a new section of code that defines functions to clean up.
 365
 366 =cut
 367
 368 sub unimport {
 369     my ($pragma, %args) = @_;
 370
 371     # the calling class, the current functions and our storage
 372     my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 373     my $functions = $pragma->get_functions($cleanee);
 374     my $store     = $pragma->get_class_store($cleanee);
 375
 376     # register all unknown previous functions as excluded
 377     for my $f (keys %$functions) {
 378         next if $store->{remove}{ $f }
 379              or $store->{exclude}{ $f };
 380         $store->{exclude}{ $f } = 1;
 381     }
 382
 383     return 1;
 384 }
 385
 386 =head2 get_class_store
 387
 388 This returns a reference to a hash in a passed package containing
 389 information about function names included and excluded from removal.
 390
 391 =cut
 392
 393 sub get_class_store {
 394     my ($pragma, $class) = @_;
 395     my $stash = Package::Stash->new($class);
 396     my $var = "%$STORAGE_VAR";
 397     $stash->add_symbol($var, {})
 398         unless $stash->has_symbol($var);
 399     return $stash->get_symbol($var);
 400 }
 401
 402 =head2 get_functions
 403
 404 Takes a class as argument and returns all currently defined functions
 405 in it as a hash reference with the function name as key and a typeglob
 406 reference to the symbol as value.
 407
 408 =cut
 409
 410 sub get_functions {
 411     my ($pragma, $class) = @_;
 412
 413     my $stash = Package::Stash->new($class);
 414     return {
 415         map { $_ => $stash->get_symbol("&$_") }
 416             $stash->list_all_symbols('CODE')
 417     };
 418 }
 419
 420 =head1 IMPLEMENTATION DETAILS
 421
 422 This module works through the effect that a
 423
 424   delete $SomePackage::{foo};
 425
 426 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
 427 (e.g., method calls) but will leave the entry alive to be called by
 428 already resolved names in the package itself. C<namespace::clean> will
 429 restore and therefor in effect keep all glob slots that aren't C<CODE>.
 430
 431 A test file has been added to the perl core to ensure that this behaviour
 432 will be stable in future releases.
 433
 434 Just for completeness sake, if you want to remove the symbol completely,
 435 use C<undef> instead.
 436
 437 =head1 CAVEATS
 438
 439 This module is fully functional in a pure-perl environment, where
 440 L<B::Hooks::EndOfScope> (with the XS dependency L<Variable::Magic>), may
 441 not be available. However in this case this module falls back to a
 442 L<tie()|perlfunc/tie> of L<%^H|perlvar/%^H>  which may or may not interfere
 443 with some crack you may be doing independently of namespace::clean.
 444
 445 If you want to ensure that your codebase is protected from this unlikely
 446 clash, you need to explicitly depend on L<B::Hooks::EndOfScope>.
 447
 448 =head1 SEE ALSO
 449
 450 L<B::Hooks::EndOfScope>
 451
 452 =head1 THANKS
 453
 454 Many thanks to Matt S Trout for the inspiration on the whole idea.
 455
 456 =head1 AUTHORS
 457
 458 =over
 459
 460 =item *
 461
 462 Robert 'phaylon' Sedlacek <rs@474.at>
 463
 464 =item *
 465
 466 Florian Ragwitz <rafl@debian.org>
 467
 468 =item *
 469
 470 Jesse Luehrs <doy@tozt.net>
 471
 472 =item *
 473
 474 Peter Rabbitson <ribasushi@cpan.org>
 475
 476 =back
 477
 478 =head1 COPYRIGHT AND LICENSE
 479
 480 This software is copyright (c) 2011 by Robert 'phaylon' Sedlacek.
 481
 482 This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.
 483
 484 =cut
 485
 486 no warnings;
 487 'Danger! Laws of Thermodynamics may not apply.'