lib/namespace/clean.pm

   1 package namespace::clean;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Package::Stash;
   7
   8 our $VERSION = '0.25';
   9 our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
  10
  11 use B::Hooks::EndOfScope 'on_scope_end';
  12
  13
  14 # Constant to optimise away the unused code branches
  15 use constant FIXUP_NEEDED => $] < 5.015_005_1;
  16 use constant FIXUP_RENAME_SUB => $] > 5.008_008_9 && $] < 5.013_005_1;
  17 {
  18   no strict;
  19   delete ${__PACKAGE__."::"}{FIXUP_NEEDED};
  20   delete ${__PACKAGE__."::"}{FIXUP_RENAME_SUB};
  21 }
  22
  23 # Debugger fixup necessary before perl 5.15.5
  24 #
  25 # In perl 5.8.9-5.12, it assumes that sub_fullname($sub) can
  26 # always be used to find the CV again.
  27 # In perl 5.8.8 and 5.14, it assumes that the name of the glob
  28 # passed to entersub can be used to find the CV.
  29 # since we are deleting the glob where the subroutine was originally
  30 # defined, those assumptions no longer hold.
  31 #
  32 # So in 5.8.9-5.12 we need to move it elsewhere and point the
  33 # CV's name to the new glob.
  34 #
  35 # In 5.8.8 and 5.14 we move it elsewhere and rename the
  36 # original glob by assigning the new glob back to it.
  37 my $sub_utils_loaded;
  38 my $DebuggerFixup = sub {
  39   my ($f, $sub, $cleanee_stash, $deleted_stash) = @_;
  40
  41   if (FIXUP_RENAME_SUB) {
  42     if (! defined $sub_utils_loaded ) {
  43       $sub_utils_loaded = do {
  44
  45         # when changing version also change in Makefile.PL
  46         my $sn_ver = 0.04;
  47         eval { require Sub::Name; Sub::Name->VERSION($sn_ver) }
  48           or die "Sub::Name $sn_ver required when running under -d or equivalent: $@";
  49
  50         # when changing version also change in Makefile.PL
  51         my $si_ver = 0.04;
  52         eval { require Sub::Identify; Sub::Identify->VERSION($si_ver) }
  53           or die "Sub::Identify $si_ver required when running under -d or equivalent: $@";
  54
  55         1;
  56       } ? 1 : 0;
  57     }
  58
  59     if ( Sub::Identify::sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
  60       my $new_fq = $deleted_stash->name . "::$f";
  61       Sub::Name::subname($new_fq, $sub);
  62       $deleted_stash->add_symbol("&$f", $sub);
  63     }
  64   }
  65   else {
  66     $deleted_stash->add_symbol("&$f", $sub);
  67   }
  68 };
  69
  70 my $RemoveSubs = sub {
  71     my $cleanee = shift;
  72     my $store   = shift;
  73     my $cleanee_stash = Package::Stash->new($cleanee);
  74     my $deleted_stash;
  75
  76   SYMBOL:
  77     for my $f (@_) {
  78
  79         # ignore already removed symbols
  80         next SYMBOL if $store->{exclude}{ $f };
  81
  82         my $sub = $cleanee_stash->get_symbol("&$f")
  83           or next SYMBOL;
  84
  85         my $need_debugger_fixup =
  86           FIXUP_NEEDED
  87             &&
  88           $^P
  89             &&
  90           ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
  91         ;
  92
  93         if (FIXUP_NEEDED && $need_debugger_fixup) {
  94           # convince the Perl debugger to work
  95           # see the comment on top of $DebuggerFixup
  96           $DebuggerFixup->(
  97             $f,
  98             $sub,
  99             $cleanee_stash,
 100             $deleted_stash ||= Package::Stash->new("namespace::clean::deleted::$cleanee"),
 101           );
 102         }
 103
 104         my @symbols = map {
 105             my $name = $_ . $f;
 106             my $def = $cleanee_stash->get_symbol($name);
 107             defined($def) ? [$name, $def] : ()
 108         } '$', '@', '%', '';
 109
 110         $cleanee_stash->remove_glob($f);
 111
 112         # if this perl needs no renaming trick we need to
 113         # rename the original glob after the fact
 114         # (see commend of $DebuggerFixup
 115         if (FIXUP_NEEDED && !FIXUP_RENAME_SUB && $need_debugger_fixup) {
 116           *$globref = $deleted_stash->namespace->{$f};
 117         }
 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     = Package::Stash->new($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 = Package::Stash->new($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 = Package::Stash->new($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.