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