lib/namespace/clean.pm

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