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