lib/namespace/clean.pm

   1 package namespace::clean;
   2
   3 use warnings;
   4 use strict;
   5
   6 our $VERSION = '0.25';
   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 =head2 Explicitly removing functions when your scope is compiled
 291
 292 It is also possible to explicitly tell C<namespace::clean> what packages
 293 to remove when the surrounding scope has finished compiling. Here is an
 294 example:
 295
 296   package Foo;
 297   use strict;
 298
 299   # blessed NOT available
 300
 301   sub my_class {
 302       use Scalar::Util qw( blessed );
 303       use namespace::clean qw( blessed );
 304
 305       # blessed available
 306       return blessed shift;
 307   }
 308
 309   # blessed NOT available
 310
 311 =head2 Moose
 312
 313 When using C<namespace::clean> together with L<Moose> you want to keep
 314 the installed C<meta> method. So your classes should look like:
 315
 316   package Foo;
 317   use Moose;
 318   use namespace::clean -except => 'meta';
 319   ...
 320
 321 Same goes for L<Moose::Role>.
 322
 323 =head2 Cleaning other packages
 324
 325 You can tell C<namespace::clean> that you want to clean up another package
 326 instead of the one importing. To do this you have to pass in the C<-cleanee>
 327 option like this:
 328
 329   package My::MooseX::namespace::clean;
 330   use strict;
 331
 332   use namespace::clean (); # no cleanup, just load
 333
 334   sub import {
 335       namespace::clean->import(
 336         -cleanee => scalar(caller),
 337         -except  => 'meta',
 338       );
 339   }
 340
 341 If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
 342 just want to remove subroutines, try L</clean_subroutines>.
 343
 344 =head1 METHODS
 345
 346 =head2 clean_subroutines
 347
 348 This exposes the actual subroutine-removal logic.
 349
 350   namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
 351
 352 will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
 353 subroutines B<immediately> and not wait for scope end. If you want to have this
 354 effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
 355 it is your responsibility to make sure it runs at that time.
 356
 357 =head2 import
 358
 359 Makes a snapshot of the current defined functions and installs a
 360 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 361
 362
 363 =head2 unimport
 364
 365 This method will be called when you do a
 366
 367   no namespace::clean;
 368
 369 It will start a new section of code that defines functions to clean up.
 370
 371 =head2 get_class_store
 372
 373 This returns a reference to a hash in a passed package containing
 374 information about function names included and excluded from removal.
 375
 376 =head2 get_functions
 377
 378 Takes a class as argument and returns all currently defined functions
 379 in it as a hash reference with the function name as key and a typeglob
 380 reference to the symbol as value.
 381
 382 =head1 IMPLEMENTATION DETAILS
 383
 384 This module works through the effect that a
 385
 386   delete $SomePackage::{foo};
 387
 388 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
 389 (e.g., method calls) but will leave the entry alive to be called by
 390 already resolved names in the package itself. C<namespace::clean> will
 391 restore and therefor in effect keep all glob slots that aren't C<CODE>.
 392
 393 A test file has been added to the perl core to ensure that this behaviour
 394 will be stable in future releases.
 395
 396 Just for completeness sake, if you want to remove the symbol completely,
 397 use C<undef> instead.
 398
 399 =head1 SEE ALSO
 400
 401 L<B::Hooks::EndOfScope>
 402
 403 =head1 THANKS
 404
 405 Many thanks to Matt S Trout for the inspiration on the whole idea.
 406
 407 =head1 AUTHORS
 408
 409 =over
 410
 411 =item *
 412
 413 Robert 'phaylon' Sedlacek <rs@474.at>
 414
 415 =item *
 416
 417 Florian Ragwitz <rafl@debian.org>
 418
 419 =item *
 420
 421 Jesse Luehrs <doy@tozt.net>
 422
 423 =item *
 424
 425 Peter Rabbitson <ribasushi@cpan.org>
 426
 427 =item *
 428
 429 Father Chrysostomos <sprout@cpan.org>
 430
 431 =back
 432
 433 =head1 COPYRIGHT AND LICENSE
 434
 435 This software is copyright (c) 2011 by L</AUTHORS>
 436
 437 This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.