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
 250         # when changing version also change in Makefile.PL
 251         my $sn_ver = 0.04;
 252         eval { require Sub::Name; Sub::Name->VERSION($sn_ver) }
 253           or die "Sub::Name $sn_ver required when running under -d or equivalent: $@";
 254
 255         # when changing version also change in Makefile.PL
 256         my $si_ver = 0.04;
 257         eval { require Sub::Identify; Sub::Identify->VERSION($si_ver) }
 258           or die "Sub::Identify $si_ver required when running under -d or equivalent: $@";
 259
 260         1;
 261       } ? 1 : 0;
 262     }
 263
 264     if ( Sub::Identify::sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
 265       my $new_fq = $deleted_stash->name . "::$f";
 266       Sub::Name::subname($new_fq, $sub);
 267       $deleted_stash->add_symbol("&$f", $sub);
 268     }
 269   }
 270   else {
 271     $deleted_stash->add_symbol("&$f", $sub);
 272   }
 273 };
 274
 275 my $RemoveSubs = sub {
 276     my $cleanee = shift;
 277     my $store   = shift;
 278     my $cleanee_stash = Package::Stash->new($cleanee);
 279     my $deleted_stash;
 280
 281   SYMBOL:
 282     for my $f (@_) {
 283
 284         # ignore already removed symbols
 285         next SYMBOL if $store->{exclude}{ $f };
 286
 287         my $sub = $cleanee_stash->get_symbol("&$f")
 288           or next SYMBOL;
 289
 290         my $need_debugger_fixup =
 291           $^P
 292             &&
 293           ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
 294         ;
 295
 296         if ($need_debugger_fixup) {
 297           # convince the Perl debugger to work
 298           # see the comment on top of $DebuggerFixup
 299           $DebuggerFixup->(
 300             $f,
 301             $sub,
 302             $cleanee_stash,
 303             $deleted_stash ||= Package::Stash->new("namespace::clean::deleted::$cleanee"),
 304           );
 305         }
 306
 307         my @symbols = map {
 308             my $name = $_ . $f;
 309             my $def = $cleanee_stash->get_symbol($name);
 310             defined($def) ? [$name, $def] : ()
 311         } '$', '@', '%', '';
 312
 313         $cleanee_stash->remove_glob($f);
 314
 315         # if this perl needs no renaming trick we need to
 316         # rename the original glob after the fact
 317         # (see commend of $DebuggerFixup
 318         if (!RENAME_SUB && $need_debugger_fixup) {
 319           *$globref = $deleted_stash->namespace->{$f};
 320         }
 321
 322         $cleanee_stash->add_symbol(@$_) for @symbols;
 323     }
 324 };
 325
 326 sub clean_subroutines {
 327     my ($nc, $cleanee, @subs) = @_;
 328     $RemoveSubs->($cleanee, {}, @subs);
 329 }
 330
 331 =head2 import
 332
 333 Makes a snapshot of the current defined functions and installs a
 334 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 335
 336 =cut
 337
 338 sub import {
 339     my ($pragma, @args) = @_;
 340
 341     my (%args, $is_explicit);
 342
 343   ARG:
 344     while (@args) {
 345
 346         if ($args[0] =~ /^\-/) {
 347             my $key = shift @args;
 348             my $value = shift @args;
 349             $args{ $key } = $value;
 350         }
 351         else {
 352             $is_explicit++;
 353             last ARG;
 354         }
 355     }
 356
 357     my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 358     if ($is_explicit) {
 359         on_scope_end {
 360             $RemoveSubs->($cleanee, {}, @args);
 361         };
 362     }
 363     else {
 364
 365         # calling class, all current functions and our storage
 366         my $functions = $pragma->get_functions($cleanee);
 367         my $store     = $pragma->get_class_store($cleanee);
 368         my $stash     = Package::Stash->new($cleanee);
 369
 370         # except parameter can be array ref or single value
 371         my %except = map {( $_ => 1 )} (
 372             $args{ -except }
 373             ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
 374             : ()
 375         );
 376
 377         # register symbols for removal, if they have a CODE entry
 378         for my $f (keys %$functions) {
 379             next if     $except{ $f };
 380             next unless $stash->has_symbol("&$f");
 381             $store->{remove}{ $f } = 1;
 382         }
 383
 384         # register EOF handler on first call to import
 385         unless ($store->{handler_is_installed}) {
 386             on_scope_end {
 387                 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 388             };
 389             $store->{handler_is_installed} = 1;
 390         }
 391
 392         return 1;
 393     }
 394 }
 395
 396 =head2 unimport
 397
 398 This method will be called when you do a
 399
 400   no namespace::clean;
 401
 402 It will start a new section of code that defines functions to clean up.
 403
 404 =cut
 405
 406 sub unimport {
 407     my ($pragma, %args) = @_;
 408
 409     # the calling class, the current functions and our storage
 410     my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 411     my $functions = $pragma->get_functions($cleanee);
 412     my $store     = $pragma->get_class_store($cleanee);
 413
 414     # register all unknown previous functions as excluded
 415     for my $f (keys %$functions) {
 416         next if $store->{remove}{ $f }
 417              or $store->{exclude}{ $f };
 418         $store->{exclude}{ $f } = 1;
 419     }
 420
 421     return 1;
 422 }
 423
 424 =head2 get_class_store
 425
 426 This returns a reference to a hash in a passed package containing
 427 information about function names included and excluded from removal.
 428
 429 =cut
 430
 431 sub get_class_store {
 432     my ($pragma, $class) = @_;
 433     my $stash = Package::Stash->new($class);
 434     my $var = "%$STORAGE_VAR";
 435     $stash->add_symbol($var, {})
 436         unless $stash->has_symbol($var);
 437     return $stash->get_symbol($var);
 438 }
 439
 440 =head2 get_functions
 441
 442 Takes a class as argument and returns all currently defined functions
 443 in it as a hash reference with the function name as key and a typeglob
 444 reference to the symbol as value.
 445
 446 =cut
 447
 448 sub get_functions {
 449     my ($pragma, $class) = @_;
 450
 451     my $stash = Package::Stash->new($class);
 452     return {
 453         map { $_ => $stash->get_symbol("&$_") }
 454             $stash->list_all_symbols('CODE')
 455     };
 456 }
 457
 458 =head1 IMPLEMENTATION DETAILS
 459
 460 This module works through the effect that a
 461
 462   delete $SomePackage::{foo};
 463
 464 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
 465 (e.g., method calls) but will leave the entry alive to be called by
 466 already resolved names in the package itself. C<namespace::clean> will
 467 restore and therefor in effect keep all glob slots that aren't C<CODE>.
 468
 469 A test file has been added to the perl core to ensure that this behaviour
 470 will be stable in future releases.
 471
 472 Just for completeness sake, if you want to remove the symbol completely,
 473 use C<undef> instead.
 474
 475 =head1 CAVEATS
 476
 477 This module is fully functional in a pure-perl environment, where
 478 L<B::Hooks::EndOfScope> (with the XS dependency L<Variable::Magic>), may
 479 not be available. However in this case this module falls back to a
 480 L<tie()|perlfunc/tie> of L<%^H|perlvar/%^H>  which may or may not interfere
 481 with some crack you may be doing independently of namespace::clean.
 482
 483 If you want to ensure that your codebase is protected from this unlikely
 484 clash, you need to explicitly depend on L<B::Hooks::EndOfScope>.
 485
 486 =head1 SEE ALSO
 487
 488 L<B::Hooks::EndOfScope>
 489
 490 =head1 THANKS
 491
 492 Many thanks to Matt S Trout for the inspiration on the whole idea.
 493
 494 =head1 AUTHORS
 495
 496 =over
 497
 498 =item *
 499
 500 Robert 'phaylon' Sedlacek <rs@474.at>
 501
 502 =item *
 503
 504 Florian Ragwitz <rafl@debian.org>
 505
 506 =item *
 507
 508 Jesse Luehrs <doy@tozt.net>
 509
 510 =item *
 511
 512 Peter Rabbitson <ribasushi@cpan.org>
 513
 514 =back
 515
 516 =head1 COPYRIGHT AND LICENSE
 517
 518 This software is copyright (c) 2011 by Robert 'phaylon' Sedlacek.
 519
 520 This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.
 521
 522 =cut
 523
 524 no warnings;
 525 'Danger! Laws of Thermodynamics may not apply.'