File Coverage

blib/lib/namespace/autoclean.pm

Criterion	Covered	Total	%
statement	59	63	93.6
branch	27	34	79.4
condition	6	12	50.0
subroutine	12	13	92.3
pod			n/a
total	104	122	85.2

use strict;
use warnings;

package namespace::autoclean; # git description: 0.28-24-g964adcf
# ABSTRACT: Keep imports out of your namespace
# KEYWORDS: namespaces clean dirty imports exports subroutines methods development

our $VERSION = '0.29';

use B::Hooks::EndOfScope 0.12;
use List::Util qw( first );
use namespace::clean 0.20;

#pod =head1 SYNOPSIS
#pod
#pod     package Foo;
#pod     use namespace::autoclean;
#pod     use Some::Package qw/imported_function/;
#pod
#pod     sub bar { imported_function('stuff') }
#pod
#pod     # later on:
#pod     Foo->bar;               # works
#pod     Foo->imported_function; # will fail. imported_function got cleaned after compilation
#pod
#pod =head1 DESCRIPTION
#pod
#pod When you import a function into a Perl package, it will naturally also be
#pod available as a method.
#pod
#pod The C pragma will remove all imported symbols at the end
#pod of the current package's compile cycle. Functions called in the package itself
#pod will still be bound by their name, but they won't show up as methods on your
#pod class or instances.
#pod
#pod This module is very similar to L, except it
#pod will clean all imported functions, no matter if you imported them before or
#pod after you Cd the pragma. It will also not touch anything that looks like a
#pod method.
#pod
#pod If you're writing an exporter and you want to clean up after yourself (and your
#pod peers), you can use the C<-cleanee> switch to specify what package to clean:
#pod
#pod   package My::MooseX::namespace::autoclean;
#pod   use strict;
#pod
#pod   use namespace::autoclean (); # no cleanup, just load
#pod
#pod   sub import {
#pod       namespace::autoclean->import(
#pod         -cleanee => scalar(caller),
#pod       );
#pod   }
#pod
#pod =head1 WHAT IS AND ISN'T CLEANED
#pod
#pod C will leave behind anything that it deems a method.  For
#pod L classes, this the based on the C method
#pod on from the L.  For non-Moose classes, anything
#pod defined within the package will be identified as a method.  This should match
#pod Moose's definition of a method.  Additionally, the magic subs installed by
#pod L will not be cleaned.
#pod
#pod =head1 PARAMETERS
#pod
#pod =head2 -also => [ ITEM | REGEX | SUB, .. ]
#pod
#pod =head2 -also => ITEM
#pod
#pod =head2 -also => REGEX
#pod
#pod =head2 -also => SUB
#pod
#pod Sometimes you don't want to clean imports only, but also helper functions
#pod you're using in your methods. The C<-also> switch can be used to declare a list
#pod of functions that should be removed additional to any imports:
#pod
#pod     use namespace::autoclean -also => ['some_function', 'another_function'];
#pod
#pod If only one function needs to be additionally cleaned the C<-also> switch also
#pod accepts a plain string:
#pod
#pod     use namespace::autoclean -also => 'some_function';
#pod
#pod In some situations, you may wish for a more I cleaning solution.
#pod
#pod The C<-also> switch can take a Regex or a CodeRef to match against local
#pod function names to clean.
#pod
#pod     use namespace::autoclean -also => qr/^_/
#pod
#pod     use namespace::autoclean -also => sub { $_ =~ m{^_} };
#pod
#pod     use namespace::autoclean -also => [qr/^_/ , qr/^hidden_/ ];
#pod
#pod     use namespace::autoclean -also => [sub { $_ =~ m/^_/ or $_ =~ m/^hidden/ }, sub { uc($_) == $_ } ];
#pod
#pod =head2 -except => [ ITEM | REGEX | SUB, .. ]
#pod
#pod =head2 -except => ITEM
#pod
#pod =head2 -except => REGEX
#pod
#pod =head2 -except => SUB
#pod
#pod This takes exactly the same options as C<-also> except that anything this
#pod matches will I be cleaned.
#pod
#pod =head1 CAVEATS
#pod
#pod When used with L classes, the heuristic used to check for methods won't
#pod work correctly for methods from roles consumed at compile time.
#pod
#pod   package My::Class;
#pod   use Moo;
#pod   use namespace::autoclean;
#pod
#pod   # Bad, any consumed methods will be cleaned
#pod   BEGIN { with 'Some::Role' }
#pod
#pod   # Good, methods from role will be maintained
#pod   with 'Some::Role';
#pod
#pod Additionally, method detection may not work properly in L classes in
#pod perls earlier than 5.10.
#pod
#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L
#pod * L
#pod * L
#pod * L
#pod * L
#pod * L
#pod * L
#pod * L
#pod
#pod =cut

sub import {
    my ($class, %args) = @_;

    my $subcast = sub {
        my $i = shift;
        return $i if ref $i eq 'CODE';
        return sub { $_ =~ $i } if ref $i eq 'Regexp';
        return sub { $_ eq $i };
    };

    my $runtest = sub {
        my ($code, $method_name) = @_;
        local $_ = $method_name;
        return $code->();
    };

    my $cleanee = exists $args{-cleanee} ? $args{-cleanee} : scalar caller;

    my @also = map $subcast->($_), (
        exists $args{-also}
        ? (ref $args{-also} eq 'ARRAY' ? @{ $args{-also} } : $args{-also})
        : ()
    );

    my @except = map $subcast->($_), (
        exists $args{-except}
        ? (ref $args{-except} eq 'ARRAY' ? @{ $args{-except} } : $args{-except})
        : ()
    );

    on_scope_end {
        my $subs = namespace::clean->get_functions($cleanee);
        my $method_check = _method_check($cleanee);

        my @clean = grep {
          my $method = $_;
          ! first { $runtest->($_, $method) } @except
            and ( !$method_check->($method)
              or first { $runtest->($_, $method) } @also)
        } keys %$subs;

        namespace::clean->clean_subroutines($cleanee, @clean);
    };
}

sub _method_check {
    my $package = shift;
    if (
      (defined &Class::MOP::class_of and my $meta = Class::MOP::class_of($package))
    ) {
        my %methods = map +($_ => 1), $meta->get_method_list;
        $methods{meta} = 1
          if $meta->isa('Moose::Meta::Role') && Moose->VERSION < 0.90;
        return sub { $_[0] =~ /^\(/ || $methods{$_[0]} };
    }
    else {
        my $does = $package->can('does') ? 'does'
                 : $package->can('DOES') ? 'DOES'
                 : undef;
        require Sub::Identify;
        return sub {
            return 1 if $_[0] =~ /^\(/;
            my $coderef = do { no strict 'refs'; \&{ $package . '::' . $_[0] } };
            my $code_stash = Sub::Identify::stash_name($coderef);
            return 1 if $code_stash eq $package;
            return 1 if $code_stash eq 'constant';
            # TODO: consider if we really need this eval
            return 1 if $does && eval { $package->$does($code_stash) };
            return 0;
        };
    }
}

1;

__END__