lib/namespace/clean.pm

   1 package namespace::clean;
   2 # ABSTRACT: Keep imports and functions out of your namespace
   3
   4 use warnings;
   5 use strict;
   6
   7 use vars qw( $STORAGE_VAR );
   8 use Sub::Name 0.04 qw(subname);
   9 use Sub::Identify 0.04 qw(sub_fullname);
  10 use Package::Stash 0.03;
  11 use B::Hooks::EndOfScope 0.07;
  12
  13 my ($ADD_SYMBOL, $HAS_SYMBOL, $GET_SYMBOL, $LIST_ALL_SYMBOLS, $REMOVE_GLOB);
  14 BEGIN {
  15     if ($Package::Stash::VERSION > 0.13) {
  16         $ADD_SYMBOL = 'add_symbol';
  17         $HAS_SYMBOL = 'has_symbol';
  18         $GET_SYMBOL = 'get_symbol';
  19         $LIST_ALL_SYMBOLS = 'list_all_symbols';
  20         $REMOVE_GLOB = 'remove_glob';
  21     }
  22     else {
  23         $ADD_SYMBOL = 'add_package_symbol';
  24         $HAS_SYMBOL = 'has_package_symbol';
  25         $GET_SYMBOL = 'get_package_symbol';
  26         $LIST_ALL_SYMBOLS = 'list_all_package_symbols';
  27         $REMOVE_GLOB = 'remove_package_glob';
  28     }
  29 }
  30
  31 $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
  32
  33 =head1 SYNOPSIS
  34
  35   package Foo;
  36   use warnings;
  37   use strict;
  38
  39   use Carp qw(croak);   # 'croak' will be removed
  40
  41   sub bar { 23 }        # 'bar' will be removed
  42
  43   # remove all previously defined functions
  44   use namespace::clean;
  45
  46   sub baz { bar() }     # 'baz' still defined, 'bar' still bound
  47
  48   # begin to collection function names from here again
  49   no namespace::clean;
  50
  51   sub quux { baz() }    # 'quux' will be removed
  52
  53   # remove all functions defined after the 'no' unimport
  54   use namespace::clean;
  55
  56   # Will print: 'No', 'No', 'Yes' and 'No'
  57   print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
  58   print +(__PACKAGE__->can('bar')   ? 'Yes' : 'No'), "\n";
  59   print +(__PACKAGE__->can('baz')   ? 'Yes' : 'No'), "\n";
  60   print +(__PACKAGE__->can('quux')  ? 'Yes' : 'No'), "\n";
  61
  62   1;
  63
  64 =head1 DESCRIPTION
  65
  66 =head2 Keeping packages clean
  67
  68 When you define a function, or import one, into a Perl package, it will
  69 naturally also be available as a method. This does not per se cause
  70 problems, but it can complicate subclassing and, for example, plugin
  71 classes that are included via multiple inheritance by loading them as
  72 base classes.
  73
  74 The C<namespace::clean> pragma will remove all previously declared or
  75 imported symbols at the end of the current package's compile cycle.
  76 Functions called in the package itself will still be bound by their
  77 name, but they won't show up as methods on your class or instances.
  78
  79 By unimporting via C<no> you can tell C<namespace::clean> to start
  80 collecting functions for the next C<use namespace::clean;> specification.
  81
  82 You can use the C<-except> flag to tell C<namespace::clean> that you
  83 don't want it to remove a certain function or method. A common use would
  84 be a module exporting an C<import> method along with some functions:
  85
  86   use ModuleExportingImport;
  87   use namespace::clean -except => [qw( import )];
  88
  89 If you just want to C<-except> a single sub, you can pass it directly.
  90 For more than one value you have to use an array reference.
  91
  92 =head2 Explicitely removing functions when your scope is compiled
  93
  94 It is also possible to explicitely tell C<namespace::clean> what packages
  95 to remove when the surrounding scope has finished compiling. Here is an
  96 example:
  97
  98   package Foo;
  99   use strict;
 100
 101   # blessed NOT available
 102
 103   sub my_class {
 104       use Scalar::Util qw( blessed );
 105       use namespace::clean qw( blessed );
 106
 107       # blessed available
 108       return blessed shift;
 109   }
 110
 111   # blessed NOT available
 112
 113 =head2 Moose
 114
 115 When using C<namespace::clean> together with L<Moose> you want to keep
 116 the installed C<meta> method. So your classes should look like:
 117
 118   package Foo;
 119   use Moose;
 120   use namespace::clean -except => 'meta';
 121   ...
 122
 123 Same goes for L<Moose::Role>.
 124
 125 =head2 Cleaning other packages
 126
 127 You can tell C<namespace::clean> that you want to clean up another package
 128 instead of the one importing. To do this you have to pass in the C<-cleanee>
 129 option like this:
 130
 131   package My::MooseX::namespace::clean;
 132   use strict;
 133
 134   use namespace::clean (); # no cleanup, just load
 135
 136   sub import {
 137       namespace::clean->import(
 138         -cleanee => scalar(caller),
 139         -except  => 'meta',
 140       );
 141   }
 142
 143 If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
 144 just want to remove subroutines, try L</clean_subroutines>.
 145
 146 =method clean_subroutines
 147
 148 This exposes the actual subroutine-removal logic.
 149
 150   namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
 151
 152 will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
 153 subroutines B<immediately> and not wait for scope end. If you want to have this
 154 effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
 155 it is your responsibility to make sure it runs at that time.
 156
 157 =cut
 158
 159 my $RemoveSubs = sub {
 160
 161     my $cleanee = shift;
 162     my $store   = shift;
 163     my $cleanee_stash = Package::Stash->new($cleanee);
 164     my $deleted_stash = Package::Stash->new("namespace::clean::deleted::$cleanee");
 165   SYMBOL:
 166     for my $f (@_) {
 167         my $variable = "&$f";
 168         # ignore already removed symbols
 169         next SYMBOL if $store->{exclude}{ $f };
 170
 171         next SYMBOL unless $cleanee_stash->$HAS_SYMBOL($variable);
 172
 173         if (ref(\$cleanee_stash->namespace->{$f}) eq 'GLOB') {
 174             # convince the Perl debugger to work
 175             # it assumes that sub_fullname($sub) can always be used to find the CV again
 176             # since we are deleting the glob where the subroutine was originally
 177             # defined, that assumption no longer holds, so we need to move it
 178             # elsewhere and point the CV's name to the new glob.
 179             my $sub = $cleanee_stash->$GET_SYMBOL($variable);
 180             if ( sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
 181                 my $new_fq = $deleted_stash->name . "::$f";
 182                 subname($new_fq, $sub);
 183                 $deleted_stash->$ADD_SYMBOL($variable, $sub);
 184             }
 185         }
 186
 187         my ($scalar, $array, $hash, $io) = map {
 188             $cleanee_stash->$GET_SYMBOL($_ . $f)
 189         } '$', '@', '%', '';
 190         $cleanee_stash->$REMOVE_GLOB($f);
 191         for my $var (['$', $scalar], ['@', $array], ['%', $hash], ['', $io]) {
 192             next unless defined $var->[1];
 193             $cleanee_stash->$ADD_SYMBOL($var->[0] . $f, $var->[1]);
 194         }
 195     }
 196 };
 197
 198 sub clean_subroutines {
 199     my ($nc, $cleanee, @subs) = @_;
 200     $RemoveSubs->($cleanee, {}, @subs);
 201 }
 202
 203 =method import
 204
 205 Makes a snapshot of the current defined functions and installs a
 206 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 207
 208 =cut
 209
 210 sub import {
 211     my ($pragma, @args) = @_;
 212
 213     my (%args, $is_explicit);
 214
 215   ARG:
 216     while (@args) {
 217
 218         if ($args[0] =~ /^\-/) {
 219             my $key = shift @args;
 220             my $value = shift @args;
 221             $args{ $key } = $value;
 222         }
 223         else {
 224             $is_explicit++;
 225             last ARG;
 226         }
 227     }
 228
 229     my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 230     if ($is_explicit) {
 231         on_scope_end {
 232             $RemoveSubs->($cleanee, {}, @args);
 233         };
 234     }
 235     else {
 236
 237         # calling class, all current functions and our storage
 238         my $functions = $pragma->get_functions($cleanee);
 239         my $store     = $pragma->get_class_store($cleanee);
 240         my $stash     = Package::Stash->new($cleanee);
 241
 242         # except parameter can be array ref or single value
 243         my %except = map {( $_ => 1 )} (
 244             $args{ -except }
 245             ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
 246             : ()
 247         );
 248
 249         # register symbols for removal, if they have a CODE entry
 250         for my $f (keys %$functions) {
 251             next if     $except{ $f };
 252             next unless $stash->$HAS_SYMBOL("&$f");
 253             $store->{remove}{ $f } = 1;
 254         }
 255
 256         # register EOF handler on first call to import
 257         unless ($store->{handler_is_installed}) {
 258             on_scope_end {
 259                 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 260             };
 261             $store->{handler_is_installed} = 1;
 262         }
 263
 264         return 1;
 265     }
 266 }
 267
 268 =method unimport
 269
 270 This method will be called when you do a
 271
 272   no namespace::clean;
 273
 274 It will start a new section of code that defines functions to clean up.
 275
 276 =cut
 277
 278 sub unimport {
 279     my ($pragma, %args) = @_;
 280
 281     # the calling class, the current functions and our storage
 282     my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 283     my $functions = $pragma->get_functions($cleanee);
 284     my $store     = $pragma->get_class_store($cleanee);
 285
 286     # register all unknown previous functions as excluded
 287     for my $f (keys %$functions) {
 288         next if $store->{remove}{ $f }
 289              or $store->{exclude}{ $f };
 290         $store->{exclude}{ $f } = 1;
 291     }
 292
 293     return 1;
 294 }
 295
 296 =method get_class_store
 297
 298 This returns a reference to a hash in a passed package containing
 299 information about function names included and excluded from removal.
 300
 301 =cut
 302
 303 sub get_class_store {
 304     my ($pragma, $class) = @_;
 305     my $stash = Package::Stash->new($class);
 306     my $var = "%$STORAGE_VAR";
 307     $stash->$ADD_SYMBOL($var, {})
 308         unless $stash->$HAS_SYMBOL($var);
 309     return $stash->$GET_SYMBOL($var);
 310 }
 311
 312 =method get_functions
 313
 314 Takes a class as argument and returns all currently defined functions
 315 in it as a hash reference with the function name as key and a typeglob
 316 reference to the symbol as value.
 317
 318 =cut
 319
 320 sub get_functions {
 321     my ($pragma, $class) = @_;
 322
 323     my $stash = Package::Stash->new($class);
 324     return {
 325         map { $_ => $stash->$GET_SYMBOL("&$_") }
 326             $stash->$LIST_ALL_SYMBOLS('CODE')
 327     };
 328 }
 329
 330 =head1 IMPLEMENTATION DETAILS
 331
 332 This module works through the effect that a
 333
 334   delete $SomePackage::{foo};
 335
 336 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
 337 (e.g., method calls) but will leave the entry alive to be called by
 338 already resolved names in the package itself. C<namespace::clean> will
 339 restore and therefor in effect keep all glob slots that aren't C<CODE>.
 340
 341 A test file has been added to the perl core to ensure that this behaviour
 342 will be stable in future releases.
 343
 344 Just for completeness sake, if you want to remove the symbol completely,
 345 use C<undef> instead.
 346
 347 =head1 SEE ALSO
 348
 349 L<B::Hooks::EndOfScope>
 350
 351 =head1 THANKS
 352
 353 Many thanks to Matt S Trout for the inspiration on the whole idea.
 354
 355 =cut
 356
 357 no warnings;
 358 'Danger! Laws of Thermodynamics may not apply.'