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         # register EOF handler on first call to import
 184         unless ($store->{handler_is_installed}) {
 185             on_scope_end {
 186                 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 187             };
 188             $store->{handler_is_installed} = 1;
 189         }
 190
 191         return 1;
 192     }
 193 }
 194
 195 sub unimport {
 196     my ($pragma, %args) = @_;
 197
 198     # the calling class, the current functions and our storage
 199     my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 200     my $functions = $pragma->get_functions($cleanee);
 201     my $store     = $pragma->get_class_store($cleanee);
 202
 203     # register all unknown previous functions as excluded
 204     for my $f (keys %$functions) {
 205         next if $store->{remove}{ $f }
 206              or $store->{exclude}{ $f };
 207         $store->{exclude}{ $f } = 1;
 208     }
 209
 210     return 1;
 211 }
 212
 213 sub get_class_store {
 214     my ($pragma, $class) = @_;
 215     my $stash = stash_for($class);
 216     my $var = "%$STORAGE_VAR";
 217     $stash->add_symbol($var, {})
 218         unless $stash->has_symbol($var);
 219     return $stash->get_symbol($var);
 220 }
 221
 222 sub get_functions {
 223     my ($pragma, $class) = @_;
 224
 225     my $stash = stash_for($class);
 226     return {
 227         map { $_ => $stash->get_symbol("&$_") }
 228             $stash->list_all_symbols('CODE')
 229     };
 230 }
 231
 232 'Danger! Laws of Thermodynamics may not apply.'
 233
 234 __END__
 235
 236 =head1 NAME
 237
 238 namespace::clean - Keep imports and functions out of your namespace
 239
 240 =head1 SYNOPSIS
 241
 242   package Foo;
 243   use warnings;
 244   use strict;
 245
 246   use Carp qw(croak);   # 'croak' will be removed
 247
 248   sub bar { 23 }        # 'bar' will be removed
 249
 250   # remove all previously defined functions
 251   use namespace::clean;
 252
 253   sub baz { bar() }     # 'baz' still defined, 'bar' still bound
 254
 255   # begin to collection function names from here again
 256   no namespace::clean;
 257
 258   sub quux { baz() }    # 'quux' will be removed
 259
 260   # remove all functions defined after the 'no' unimport
 261   use namespace::clean;
 262
 263   # Will print: 'No', 'No', 'Yes' and 'No'
 264   print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
 265   print +(__PACKAGE__->can('bar')   ? 'Yes' : 'No'), "\n";
 266   print +(__PACKAGE__->can('baz')   ? 'Yes' : 'No'), "\n";
 267   print +(__PACKAGE__->can('quux')  ? 'Yes' : 'No'), "\n";
 268
 269   1;
 270
 271 =head1 DESCRIPTION
 272
 273 =head2 Keeping packages clean
 274
 275 When you define a function, or import one, into a Perl package, it will
 276 naturally also be available as a method. This does not per se cause
 277 problems, but it can complicate subclassing and, for example, plugin
 278 classes that are included via multiple inheritance by loading them as
 279 base classes.
 280
 281 The C<namespace::clean> pragma will remove all previously declared or
 282 imported symbols at the end of the current package's compile cycle.
 283 Functions called in the package itself will still be bound by their
 284 name, but they won't show up as methods on your class or instances.
 285
 286 By unimporting via C<no> you can tell C<namespace::clean> to start
 287 collecting functions for the next C<use namespace::clean;> specification.
 288
 289 You can use the C<-except> flag to tell C<namespace::clean> that you
 290 don't want it to remove a certain function or method. A common use would
 291 be a module exporting an C<import> method along with some functions:
 292
 293   use ModuleExportingImport;
 294   use namespace::clean -except => [qw( import )];
 295
 296 If you just want to C<-except> a single sub, you can pass it directly.
 297 For more than one value you have to use an array reference.
 298
 299 =head3 Late binding caveat
 300
 301 Note that the L<technique used by this module|/IMPLEMENTATION DETAILS> relies
 302 on perl having resolved all names to actual code references during the
 303 compilation of a scope. While this is almost always what the interpreter does,
 304 there are some exceptions, notably the L<sort SUBNAME|perlfunc/sort> style of
 305 the C<sort> built-in invocation. The following example will not work, because
 306 C<sort> does not try to resolve the function name to an actual code reference
 307 until B<runtime>.
 308
 309  use MyApp::Utils 'my_sorter';
 310  use namespace::clean;
 311
 312  my @sorted = sort my_sorter @list;
 313
 314 You need to work around this by forcing a compile-time resolution like so:
 315
 316  use MyApp::Utils 'sorter';
 317  use namespace::clean;
 318
 319  my $my_sorter_cref = \&sorter;
 320
 321  my @sorted = sort $my_sorter_cref @list;
 322
 323 =head2 Explicitly removing functions when your scope is compiled
 324
 325 It is also possible to explicitly tell C<namespace::clean> what packages
 326 to remove when the surrounding scope has finished compiling. Here is an
 327 example:
 328
 329   package Foo;
 330   use strict;
 331
 332   # blessed NOT available
 333
 334   sub my_class {
 335       use Scalar::Util qw( blessed );
 336       use namespace::clean qw( blessed );
 337
 338       # blessed available
 339       return blessed shift;
 340   }
 341
 342   # blessed NOT available
 343
 344 =head2 Moose
 345
 346 When using C<namespace::clean> together with L<Moose> you want to keep
 347 the installed C<meta> method. So your classes should look like:
 348
 349   package Foo;
 350   use Moose;
 351   use namespace::clean -except => 'meta';
 352   ...
 353
 354 Same goes for L<Moose::Role>.
 355
 356 =head2 Cleaning other packages
 357
 358 You can tell C<namespace::clean> that you want to clean up another package
 359 instead of the one importing. To do this you have to pass in the C<-cleanee>
 360 option like this:
 361
 362   package My::MooseX::namespace::clean;
 363   use strict;
 364
 365   use namespace::clean (); # no cleanup, just load
 366
 367   sub import {
 368       namespace::clean->import(
 369         -cleanee => scalar(caller),
 370         -except  => 'meta',
 371       );
 372   }
 373
 374 If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
 375 just want to remove subroutines, try L</clean_subroutines>.
 376
 377 =head1 METHODS
 378
 379 =head2 clean_subroutines
 380
 381 This exposes the actual subroutine-removal logic.
 382
 383   namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
 384
 385 will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
 386 subroutines B<immediately> and not wait for scope end. If you want to have this
 387 effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
 388 it is your responsibility to make sure it runs at that time.
 389
 390 =head2 import
 391
 392 Makes a snapshot of the current defined functions and installs a
 393 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 394
 395
 396 =head2 unimport
 397
 398 This method will be called when you do a
 399
 400   no namespace::clean;
 401
 402 It will start a new section of code that defines functions to clean up.
 403
 404 =head2 get_class_store
 405
 406 This returns a reference to a hash in a passed package containing
 407 information about function names included and excluded from removal.
 408
 409 =head2 get_functions
 410
 411 Takes a class as argument and returns all currently defined functions
 412 in it as a hash reference with the function name as key and a typeglob
 413 reference to the symbol as value.
 414
 415 =head1 IMPLEMENTATION DETAILS
 416
 417 This module works through the effect that a
 418
 419   delete $SomePackage::{foo};
 420
 421 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
 422 (e.g., method calls) but will leave the entry alive to be called by
 423 already resolved names in the package itself. C<namespace::clean> will
 424 restore and therefor in effect keep all glob slots that aren't C<CODE>.
 425
 426 A test file has been added to the perl core to ensure that this behaviour
 427 will be stable in future releases.
 428
 429 Just for completeness sake, if you want to remove the symbol completely,
 430 use C<undef> instead.
 431
 432 =head1 SEE ALSO
 433
 434 L<B::Hooks::EndOfScope>
 435
 436 =head1 THANKS
 437
 438 Many thanks to Matt S Trout for the inspiration on the whole idea.
 439
 440 =head1 AUTHORS
 441
 442 =over
 443
 444 =item *
 445
 446 Robert 'phaylon' Sedlacek <rs@474.at>
 447
 448 =item *
 449
 450 Florian Ragwitz <rafl@debian.org>
 451
 452 =item *
 453
 454 Jesse Luehrs <doy@tozt.net>
 455
 456 =item *
 457
 458 Peter Rabbitson <ribasushi@cpan.org>
 459
 460 =item *
 461
 462 Father Chrysostomos <sprout@cpan.org>
 463
 464 =back
 465
 466 =head1 COPYRIGHT AND LICENSE
 467
 468 This software is copyright (c) 2011 by L</AUTHORS>
 469
 470 This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.