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.11
  21
  22 =cut
  23
  24 $VERSION         = '0.11';
  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         # convince the Perl debugger to work
 173         # it assumes that sub_fullname($sub) can always be used to find the CV again
 174         # since we are deleting the glob where the subroutine was originally
 175         # defined, that assumption no longer holds, so we need to move it
 176         # elsewhere and point the CV's name to the new glob.
 177         my $sub = \&$fq;
 178         if ( sub_fullname($sub) eq $fq ) {
 179             my $new_fq = "namespace::clean::deleted::$fq";
 180             subname($new_fq, $sub);
 181             *{$new_fq} = $sub;
 182         }
 183
 184         local *__tmp;
 185
 186         # keep original value to restore non-code slots
 187         {   no warnings 'uninitialized';    # fix possible unimports
 188             *__tmp = *{ ${ "${cleanee}::" }{ $f } };
 189             delete ${ "${cleanee}::" }{ $f };
 190         }
 191
 192       SLOT:
 193         # restore non-code slots to symbol.
 194         # omit the FORMAT slot, since perl erroneously puts it into the
 195         # SCALAR slot of the new glob.
 196         for my $t (qw( SCALAR ARRAY HASH IO )) {
 197             next SLOT unless defined *__tmp{ $t };
 198             *{ "${cleanee}::$f" } = *__tmp{ $t };
 199         }
 200     }
 201 };
 202
 203 sub clean_subroutines {
 204     my ($nc, $cleanee, @subs) = @_;
 205     $RemoveSubs->($cleanee, {}, @subs);
 206 }
 207
 208 =head2 import
 209
 210 Makes a snapshot of the current defined functions and installs a
 211 L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
 212
 213 =cut
 214
 215 sub import {
 216     my ($pragma, @args) = @_;
 217
 218     my (%args, $is_explicit);
 219
 220   ARG:
 221     while (@args) {
 222
 223         if ($args[0] =~ /^\-/) {
 224             my $key = shift @args;
 225             my $value = shift @args;
 226             $args{ $key } = $value;
 227         }
 228         else {
 229             $is_explicit++;
 230             last ARG;
 231         }
 232     }
 233
 234     my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 235     if ($is_explicit) {
 236         on_scope_end {
 237             $RemoveSubs->($cleanee, {}, @args);
 238         };
 239     }
 240     else {
 241
 242         # calling class, all current functions and our storage
 243         my $functions = $pragma->get_functions($cleanee);
 244         my $store     = $pragma->get_class_store($cleanee);
 245
 246         # except parameter can be array ref or single value
 247         my %except = map {( $_ => 1 )} (
 248             $args{ -except }
 249             ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
 250             : ()
 251         );
 252
 253         # register symbols for removal, if they have a CODE entry
 254         for my $f (keys %$functions) {
 255             next if     $except{ $f };
 256             next unless    $functions->{ $f }
 257                     and *{ $functions->{ $f } }{CODE};
 258             $store->{remove}{ $f } = 1;
 259         }
 260
 261         # register EOF handler on first call to import
 262         unless ($store->{handler_is_installed}) {
 263             on_scope_end {
 264                 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 265             };
 266             $store->{handler_is_installed} = 1;
 267         }
 268
 269         return 1;
 270     }
 271 }
 272
 273 =head2 unimport
 274
 275 This method will be called when you do a
 276
 277   no namespace::clean;
 278
 279 It will start a new section of code that defines functions to clean up.
 280
 281 =cut
 282
 283 sub unimport {
 284     my ($pragma, %args) = @_;
 285
 286     # the calling class, the current functions and our storage
 287     my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 288     my $functions = $pragma->get_functions($cleanee);
 289     my $store     = $pragma->get_class_store($cleanee);
 290
 291     # register all unknown previous functions as excluded
 292     for my $f (keys %$functions) {
 293         next if $store->{remove}{ $f }
 294              or $store->{exclude}{ $f };
 295         $store->{exclude}{ $f } = 1;
 296     }
 297
 298     return 1;
 299 }
 300
 301 =head2 get_class_store
 302
 303 This returns a reference to a hash in a passed package containing
 304 information about function names included and excluded from removal.
 305
 306 =cut
 307
 308 sub get_class_store {
 309     my ($pragma, $class) = @_;
 310     no strict 'refs';
 311     return \%{ "${class}::${STORAGE_VAR}" };
 312 }
 313
 314 =head2 get_functions
 315
 316 Takes a class as argument and returns all currently defined functions
 317 in it as a hash reference with the function name as key and a typeglob
 318 reference to the symbol as value.
 319
 320 =cut
 321
 322 sub get_functions {
 323     my ($pragma, $class) = @_;
 324
 325     return {
 326         map  { @$_ }                                        # key => value
 327         grep { *{ $_->[1] }{CODE} }                         # only functions
 328         map  { [$_, qualify_to_ref( $_, $class )] }         # get globref
 329         grep { $_ !~ /::$/ }                                # no packages
 330         do   { no strict 'refs'; keys %{ "${class}::" } }   # symbol entries
 331     };
 332 }
 333
 334 =head1 BUGS
 335
 336 C<namespace::clean> will clobber any formats that have the same name as
 337 a deleted sub. This is due to a bug in perl that makes it impossible to
 338 re-assign the FORMAT ref into a new glob.
 339
 340 =head1 IMPLEMENTATION DETAILS
 341
 342 This module works through the effect that a
 343
 344   delete $SomePackage::{foo};
 345
 346 will remove the C<foo> symbol from C<$SomePackage> for run time lookups
 347 (e.g., method calls) but will leave the entry alive to be called by
 348 already resolved names in the package itself. C<namespace::clean> will
 349 restore and therefor in effect keep all glob slots that aren't C<CODE>.
 350
 351 A test file has been added to the perl core to ensure that this behaviour
 352 will be stable in future releases.
 353
 354 Just for completeness sake, if you want to remove the symbol completely,
 355 use C<undef> instead.
 356
 357 =head1 SEE ALSO
 358
 359 L<B::Hooks::EndOfScope>
 360
 361 =head1 AUTHOR AND COPYRIGHT
 362
 363 Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
 364 Matt S Trout for the inspiration on the whole idea.
 365
 366 =head1 LICENSE
 367
 368 This program is free software; you can redistribute it and/or modify
 369 it under the same terms as perl itself.
 370
 371 =cut
 372
 373 no warnings;
 374 'Danger! Laws of Thermodynamics may not apply.'