File Coverage

blib/lib/namespace/clean.pm

Criterion	Covered	Total	%
statement	66	68	97.0
branch	22	26	84.6
condition	2	3	66.6
subroutine	13	13	100.0
pod	3	4	75.0
total	106	114	92.9

package namespace::clean;

use warnings;
use strict;

our $VERSION = '0.25_02';
our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';

use B::Hooks::EndOfScope 'on_scope_end';

# FIXME This is a crock of shit, needs to go away
# currently here to work around https://rt.cpan.org/Ticket/Display.html?id=74151
# kill with fire when PS::XS is *finally* fixed
BEGIN {
  my $provider;

  if ( $] < 5.008007 ) {
    require Package::Stash::PP;
    $provider = 'Package::Stash::PP';
  }
  else {
    require Package::Stash;
    $provider = 'Package::Stash';
  }
  eval <<"EOS" or die $@;

sub stash_for (\$) {
  $provider->new(\$_[0]);
}

1;

EOS
}

use namespace::clean::_Util qw( DEBUGGER_NEEDS_CV_RENAME DEBUGGER_NEEDS_CV_PIVOT );

# Built-in debugger CV-retrieval fixups necessary before perl 5.15.5:
# since we are deleting the glob where the subroutine was originally
# defined, the assumptions below no longer hold.
#
# In 5.8.9 ~ 5.13.5 (inclusive) the debugger assumes that a CV can
# always be found under sub_fullname($sub)
# Workaround: use sub naming to properly name the sub hidden in the package's
# deleted-stash
#
# In the rest of the range ( ... ~ 5.8.8 and 5.13.6 ~ 5.15.4 ) the debugger
# assumes the name of the glob passed to entersub can be used to find the CV
# Workaround: realias the original glob to the deleted-stash slot
#
# Can not tie constants to the current value of $^P directly,
# as the debugger can be enabled during runtime (kinda dubious)
#

my $RemoveSubs = sub {
    my $cleanee = shift;
    my $store   = shift;
    my $cleanee_stash = stash_for($cleanee);
    my $deleted_stash;

  SYMBOL:
    for my $f (@_) {

        # ignore already removed symbols
        next SYMBOL if $store->{exclude}{ $f };

        my $sub = $cleanee_stash->get_symbol("&$f")
          or next SYMBOL;

        my $need_debugger_fixup =
          ( DEBUGGER_NEEDS_CV_RENAME or DEBUGGER_NEEDS_CV_PIVOT )
            &&
          $^P
            &&
          ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
            &&
         ( $deleted_stash ||= stash_for("namespace::clean::deleted::$cleanee") )
        ;

        # convince the Perl debugger to work
        # see the comment on top
        if ( DEBUGGER_NEEDS_CV_RENAME and $need_debugger_fixup ) {
          namespace::clean::_Util::get_subname( $sub ) eq  ( $cleanee_stash->name . "::$f" )
            and
          $deleted_stash->add_symbol(
            "&$f",
            namespace::clean::_Util::set_subname( $deleted_stash->name . "::$f", $sub ),
          );
        }
        elsif ( DEBUGGER_NEEDS_CV_PIVOT and $need_debugger_fixup ) {
          $deleted_stash->add_symbol("&$f", $sub);
        }

        my @symbols = map {
            my $name = $_ . $f;
            my $def = $cleanee_stash->get_symbol($name);
            defined($def) ? [$name, $def] : ()
        } '$', '@', '%', '';

        $cleanee_stash->remove_glob($f);

        # if this perl needs no renaming trick we need to
        # rename the original glob after the fact
        DEBUGGER_NEEDS_CV_PIVOT
          and
        $need_debugger_fixup
          and
        *$globref = $deleted_stash->namespace->{$f};

        $cleanee_stash->add_symbol(@$_) for @symbols;
    }
};

sub clean_subroutines {
    my ($nc, $cleanee, @subs) = @_;
    $RemoveSubs->($cleanee, {}, @subs);
}

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

    my (%args, $is_explicit);

  ARG:
    while (@args) {

        if ($args[0] =~ /^\-/) {
            my $key = shift @args;
            my $value = shift @args;
            $args{ $key } = $value;
        }
        else {
            $is_explicit++;
            last ARG;
        }
    }

    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
    if ($is_explicit) {
        on_scope_end {
            $RemoveSubs->($cleanee, {}, @args);
        };
    }
    else {

        # calling class, all current functions and our storage
        my $functions = $pragma->get_functions($cleanee);
        my $store     = $pragma->get_class_store($cleanee);
        my $stash     = stash_for($cleanee);

        # except parameter can be array ref or single value
        my %except = map {( $_ => 1 )} (
            $args{ -except }
            ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
            : ()
        );

        # register symbols for removal, if they have a CODE entry
        for my $f (keys %$functions) {
            next if     $except{ $f };
            next unless $stash->has_symbol("&$f");
            $store->{remove}{ $f } = 1;
        }

        # register EOF handler on first call to import
        unless ($store->{handler_is_installed}) {
            on_scope_end {
                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
            };
            $store->{handler_is_installed} = 1;
        }

        return 1;
    }
}

sub unimport {
    my ($pragma, %args) = @_;

    # the calling class, the current functions and our storage
    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
    my $functions = $pragma->get_functions($cleanee);
    my $store     = $pragma->get_class_store($cleanee);

    # register all unknown previous functions as excluded
    for my $f (keys %$functions) {
        next if $store->{remove}{ $f }
             or $store->{exclude}{ $f };
        $store->{exclude}{ $f } = 1;
    }

    return 1;
}

sub get_class_store {
    my ($pragma, $class) = @_;
    my $stash = stash_for($class);
    my $var = "%$STORAGE_VAR";
    $stash->add_symbol($var, {})
        unless $stash->has_symbol($var);
    return $stash->get_symbol($var);
}

sub get_functions {
    my ($pragma, $class) = @_;

    my $stash = stash_for($class);
    return {
        map { $_ => $stash->get_symbol("&$_") }
            $stash->list_all_symbols('CODE')
    };
}

'Danger! Laws of Thermodynamics may not apply.'

__END__