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