lib/namespace/clean.pm

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