lib/namespace/clean.pm

   1 package namespace::clean;
   2
   3 use warnings;
   4 use strict;
   5
   6 our $VERSION = '0.25';
   7 our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
   8
   9 use B::Hooks::EndOfScope 'on_scope_end';
  10
  11 # FIXME This is a crock of shit, needs to go away
  12 # currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151
  13 # kill with fire when PS::XS is *finally* fixed
  14 BEGIN {
  15   my $provider;
  16
  17   if ( $] < 5.008007 ) {
  18     require Package::Stash::PP;
  19     $provider = 'Package::Stash::PP';
  20   }
  21   else {
  22     require Package::Stash;
  23     $provider = 'Package::Stash';
  24   }
  25   eval <<"EOS" or die $@;
  26
  27 sub stash_for (\$) {
  28   $provider->new(\$_[0]);
  29 }
  30
  31 1;
  32
  33 EOS
  34 }
  35
  36 use namespace::clean::_Util qw( DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT );
  37
  38 # Built-in debugger CV-retrieval fixups necessary before perl 5.15.5:
  39 # since we are deleting the glob where the subroutine was originally
  40 # defined, the assumptions below no longer hold.
  41 #
  42 # In 5.8.9 ~ 5.13.5 (inclusive) the debugger assumes that a CV can
  43 # always be found under sub_fullname($sub)
  44 # Workaround: use sub naming to properly name the sub hidden in the package's
  45 # deleted-stash
  46 #
  47 # In the rest of the range ( ... ~ 5.8.8 and 5.13.6 ~ 5.15.4 ) the debugger
  48 # assumes the name of the glob passed to entersub can be used to find the CV
  49 # Workaround: realias the original glob to the deleted-stash slot
  50 #
  51 # Can not tie constants to the current value of $^P directly,
  52 # as the debugger can be enabled during runtime (kinda dubious)
  53 #
  54
  55 my $RemoveSubs = sub {
  56     my $cleanee = shift;
  57     my $store   = shift;
  58     my $cleanee_stash = stash_for($cleanee);
  59     my $deleted_stash;
  60
  61   SYMBOL:
  62     for my $f (@_) {
  63
  64         # ignore already removed symbols
  65         next SYMBOL if $store->{exclude}{ $f };
  66
  67         my $sub = $cleanee_stash->get_symbol("&$f")
  68           or next SYMBOL;
  69
  70         my $need_debugger_fixup =
  71           ( DEBUGGER_NEEDS_CV_RENAME or DEBUGGER_NEEDS_CV_PIVOT )
  72             &&
  73           $^P
  74             &&
  75           ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
  76             &&
  77          ( $deleted_stash ||= stash_for("namespace::clean::deleted::$cleanee") )
  78         ;
  79
  80         # convince the Perl debugger to work
  81         # see the comment on top
  82         if ( DEBUGGER_NEEDS_CV_RENAME and $need_debugger_fixup ) {
  83           #
  84           # Note - both get_subname and set_subname are only compiled when CV_RENAME
  85           # is true ( the 5.8.9 ~ 5.12 range ). On other perls this entire block is
  86           # constant folded away, and so are the definitions in ::_Util
  87           #
  88           # Do not be surprised that they are missing without DEBUGGER_NEEDS_CV_RENAME
  89           #
  90           namespace::clean::_Util::get_subname( $sub ) eq  ( $cleanee_stash->name . "::$f" )
  91             and
  92           $deleted_stash->add_symbol(
  93             "&$f",
  94             namespace::clean::_Util::set_subname( $deleted_stash->name . "::$f", $sub ),
  95           );
  96         }
  97         elsif ( DEBUGGER_NEEDS_CV_PIVOT and $need_debugger_fixup ) {
  98           $deleted_stash->add_symbol("&$f", $sub);
  99         }
 100
 101         my @symbols = map {
 102             my $name = $_ . $f;
 103             my $def = $cleanee_stash->get_symbol($name);
 104             defined($def) ? [$name, $def] : ()
 105         } '$', '@', '%', '';
 106
 107         $cleanee_stash->remove_glob($f);
 108
 109         # if this perl needs no renaming trick we need to
 110         # rename the original glob after the fact
 111         DEBUGGER_NEEDS_CV_PIVOT
 112           and
 113         $need_debugger_fixup
 114           and
 115         *$globref = $deleted_stash->namespace->{$f};
 116
 117         $cleanee_stash->add_symbol(@$_) for @symbols;
 118     }
 119 };
 120
 121 sub clean_subroutines {
 122     my ($nc, $cleanee, @subs) = @_;
 123     $RemoveSubs->($cleanee, {}, @subs);
 124 }
 125
 126 sub import {
 127     my ($pragma, @args) = @_;
 128
 129     my (%args, $is_explicit);
 130
 131   ARG:
 132     while (@args) {
 133
 134         if ($args[0] =~ /^\-/) {
 135             my $key = shift @args;
 136             my $value = shift @args;
 137             $args{ $key } = $value;
 138         }
 139         else {
 140             $is_explicit++;
 141             last ARG;
 142         }
 143     }
 144
 145     my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 146     if ($is_explicit) {
 147         on_scope_end {
 148             $RemoveSubs->($cleanee, {}, @args);
 149         };
 150     }
 151     else {
 152
 153         # calling class, all current functions and our storage
 154         my $functions = $pragma->get_functions($cleanee);
 155         my $store     = $pragma->get_class_store($cleanee);
 156         my $stash     = stash_for($cleanee);
 157
 158         # except parameter can be array ref or single value
 159         my %except = map {( $_ => 1 )} (
 160             $args{ -except }
 161             ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
 162             : ()
 163         );
 164
 165         # register symbols for removal, if they have a CODE entry
 166         for my $f (keys %$functions) {
 167             next if     $except{ $f };
 168             next unless $stash->has_symbol("&$f");
 169             $store->{remove}{ $f } = 1;
 170         }
 171
 172         # register EOF handler on first call to import
 173         unless ($store->{handler_is_installed}) {
 174             on_scope_end {
 175                 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 176             };
 177             $store->{handler_is_installed} = 1;
 178         }
 179
 180         return 1;
 181     }
 182 }
 183
 184 sub unimport {
 185     my ($pragma, %args) = @_;
 186
 187     # the calling class, the current functions and our storage
 188     my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 189     my $functions = $pragma->get_functions($cleanee);
 190     my $store     = $pragma->get_class_store($cleanee);
 191
 192     # register all unknown previous functions as excluded
 193     for my $f (keys %$functions) {
 194         next if $store->{remove}{ $f }
 195              or $store->{exclude}{ $f };
 196         $store->{exclude}{ $f } = 1;
 197     }
 198
 199     return 1;
 200 }
 201
 202 sub get_class_store {
 203     my ($pragma, $class) = @_;
 204     my $stash = stash_for($class);
 205     my $var = "%$STORAGE_VAR";
 206     $stash->add_symbol($var, {})
 207         unless $stash->has_symbol($var);
 208     return $stash->get_symbol($var);
 209 }
 210
 211 sub get_functions {
 212     my ($pragma, $class) = @_;
 213
 214     my $stash = stash_for($class);
 215     return {
 216         map { $_ => $stash->get_symbol("&$_") }
 217             $stash->list_all_symbols('CODE')
 218     };
 219 }
 220
 221 'Danger! Laws of Thermodynamics may not apply.'
 222
 223 __END__
 224
 225 =head1 NAME
 226
 227 namespace::clean - Keep imports and functions out of your namespace
 228
 229 =head1 SYNOPSIS
 230
 231   package Foo;
 232   use warnings;
 233   use strict;
 234
 235   use Carp qw(croak);   # 'croak' will be removed
 236
 237   sub bar { 23 }        # 'bar' will be removed
 238
 239   # remove all previously defined functions
 240   use namespace::clean;
 241
 242   sub baz { bar() }     # 'baz' still defined, 'bar' still bound
 243
 244   # begin to collection function names from here again
 245   no namespace::clean;
 246
 247   sub quux { baz() }    # 'quux' will be removed
 248
 249   # remove all functions defined after the 'no' unimport
 250   use namespace::clean;
 251
 252   # Will print: 'No', 'No', 'Yes' and 'No'
 253   print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
 254   print +(__PACKAGE__->can('bar')   ? 'Yes' : 'No'), "\n";
 255   print +(__PACKAGE__->can('baz')   ? 'Yes' : 'No'), "\n";
 256   print +(__PACKAGE__->can('quux')  ? 'Yes' : 'No'), "\n";
 257
 258   1;
 259
 260 =head1 DESCRIPTION
 261
 262 =head2 Keeping packages clean
 263
 264 When you define a function, or import one, into a Perl package, it will
 265 naturally also be available as a method. This does not per se cause
 266 problems, but it can complicate subclassing and, for example, plugin
 267 classes that are included via multiple inheritance by loading them as
 268 base classes.
 269
 270 The C<namespace::clean> pragma will remove all previously declared or
 271 imported symbols at the end of the current package's compile cycle.
 272 Functions called in the package itself will still be bound by their
 273 name, but they won't show up as methods on your class or instances.
 274
 275 By unimporting via C<no> you can tell C<namespace::clean> to start
 276 collecting functions for the next C<use namespace::clean;> specification.
 277
 278 You can use the C<-except> flag to tell C<namespace::clean> that you
 279 don't want it to remove a certain function or method. A common use would
 280 be a module exporting an C<import> method along with some functions:
 281
 282   use ModuleExportingImport;
 283   use namespace::clean -except => [qw( import )];
 284
 285 If you just want to C<-except> a single sub, you can pass it directly.
 286 For more than one value you have to use an array reference.
 287
 288 =head2 Explicitly removing functions when your scope is compiled
 289
 290 It is also possible to explicitly tell C<namespace::clean> what packages
 291 to remove when the surrounding scope has finished compiling. Here is an
 292 example:
 293
 294   package Foo;
 295   use strict;
 296
 297   # blessed NOT available
 298
 299   sub my_class {
 300       use Scalar::Util qw( blessed );
 301       use namespace::clean qw( blessed );
 302
 303       # blessed available
 304       return blessed shift;
 305   }
 306
 307   # blessed NOT available
 308
 309 =head2 Moose
 310
 311 When using C<namespace::clean> together with L<Moose> you want to keep
 312 the installed C<meta> method. So your classes should look like:
 313
 314   package Foo;
 315   use Moose;
 316   use namespace::clean -except => 'meta';
 317   ...
 318
 319 Same goes for L<Moose::Role>.
 320
 321 =head2 Cleaning other packages
 322
 323 You can tell C<namespace::clean> that you want to clean up another package
 324 instead of the one importing. To do this you have to pass in the C<-cleanee>
 325 option like this:
 326
 327   package My::MooseX::namespace::clean;
 328   use strict;
 329
 330   use namespace::clean (); # no cleanup, just load
 331
 332   sub import {
 333       namespace::clean->import(
 334         -cleanee => scalar(caller),
 335         -except  => 'meta',
 336       );
 337   }
 338
 339 If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
 340 just want to remove subroutines, try L</clean_subroutines>.
 341
 342 =head1 METHODS
 343
 344 =head2 clean_subroutines
 345
 346 This exposes the actual subroutine-removal logic.
 347
 348   namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
 349
 350 will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
 351 subroutines B<immediately> and not wait for scope end. If you want to have this
 352 effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
 353 it is your responsibility to make sure it runs at that time.
 354
 355 =head2 import
 356
 357 Makes a snapshot of the current defined functions and installs a
 358 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 359
 360
 361 =head2 unimport
 362
 363 This method will be called when you do a
 364
 365   no namespace::clean;
 366
 367 It will start a new section of code that defines functions to clean up.
 368
 369 =head2 get_class_store
 370
 371 This returns a reference to a hash in a passed package containing
 372 information about function names included and excluded from removal.
 373
 374 =head2 get_functions
 375
 376 Takes a class as argument and returns all currently defined functions
 377 in it as a hash reference with the function name as key and a typeglob
 378 reference to the symbol as value.
 379
 380 =head1 IMPLEMENTATION DETAILS
 381
 382 This module works through the effect that a
 383
 384   delete $SomePackage::{foo};
 385
 386 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
 387 (e.g., method calls) but will leave the entry alive to be called by
 388 already resolved names in the package itself. C<namespace::clean> will
 389 restore and therefor in effect keep all glob slots that aren't C<CODE>.
 390
 391 A test file has been added to the perl core to ensure that this behaviour
 392 will be stable in future releases.
 393
 394 Just for completeness sake, if you want to remove the symbol completely,
 395 use C<undef> instead.
 396
 397 =head1 SEE ALSO
 398
 399 L<B::Hooks::EndOfScope>
 400
 401 =head1 THANKS
 402
 403 Many thanks to Matt S Trout for the inspiration on the whole idea.
 404
 405 =head1 AUTHORS
 406
 407 =over
 408
 409 =item *
 410
 411 Robert 'phaylon' Sedlacek <rs@474.at>
 412
 413 =item *
 414
 415 Florian Ragwitz <rafl@debian.org>
 416
 417 =item *
 418
 419 Jesse Luehrs <doy@tozt.net>
 420
 421 =item *
 422
 423 Peter Rabbitson <ribasushi@cpan.org>
 424
 425 =item *
 426
 427 Father Chrysostomos <sprout@cpan.org>
 428
 429 =back
 430
 431 =head1 COPYRIGHT AND LICENSE
 432
 433 This software is copyright (c) 2011 by L</AUTHORS>
 434
 435 This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.