lib/namespace/clean.pm

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