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