lib/namespace/clean.pm

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