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