File Coverage

blib/lib/Sub/Delete.pm

Criterion	Covered	Total	%
statement	38	38	100.0
branch	11	16	68.7
condition	18	25	72.0
subroutine	7	7	100.0
pod	0	2	0.0
total	74	88	84.0

use 5.008003;

package Sub::Delete;

$VERSION = '1.00002';
@EXPORT = delete_sub;

use Exporter 5.57 'import';
use constant point0 => 0+$] eq 5.01;

# This sub must come before any lexical vars.
sub strict_eval($) {
 local %^H if point0;
 local *@;
 use#
  strict 'vars';
 local $SIG{__WARN__} = sub {};
 eval shift
}

my %sigils = qw( SCALAR $  ARRAY @  HASH % );

sub delete_sub {
	my $sub = shift;
	my($stashname, $key) = $sub =~ /(.*::)((?:(?!::).)*)\z/s
		? ($1,$2) : (caller()."::", $sub);
	exists +(my $stash = \%$stashname)->{$key} or return;
	ref $stash->{$key} eq 'SCALAR' and  # perl5.10 constant
		delete $stash->{$key}, return;
	my $globname = "$stashname$key";
	my $glob = *$globname; # autovivify the glob in case future perl
	defined *$glob{CODE} or return;  # versions add new funny stuff
	my $check_importedness
	 = $stashname =~ /^(?:(?!\d)\w*(?:::\w*)*)\z/
	   && $key    =~ /^(?!\d)\w+\z/;
	my %imported_slots;
	my $package;
	if($check_importedness) {
		$package = substr $stashname, 0, -2;
		for (qw "SCALAR ARRAY HASH") {
			defined *$glob{$_} or next;
			$imported_slots{$_} = strict_eval
			  "package $package; 0 && $sigils{$_}$key; 1"
		}
	}
        delete $stash->{$key};
	keys %imported_slots == 1 and exists $imported_slots{SCALAR}
	 and !$imported_slots{SCALAR} and Internals'SvREFCNT $$glob =>== 1
	 and !defined *$glob{IO} and !defined *$glob{FORMAT}
	 and return; # empty glob
	my $newglob = \*$globname;
	local *alias = *$newglob;
	defined *$glob{$_} and (
	 !$check_importedness || $imported_slots{$_}
	  ? *$newglob
	  : *alias
	) = *$glob{$_}
		for qw "SCALAR ARRAY HASH";
	defined *$glob{$_} and *$newglob = *$glob{$_}
		for qw "IO FORMAT";
	return # nothing;
}

1;

__END__