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