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