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