lib/namespace/clean.pm

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