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