Alt-Sub-Delete-NewPackageSeparator
view release on metacpan or search on metacpan
lib/Sub/Delete.pm view on Meta::CPAN
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__
=pod
lib/Sub/Delete.pm view on Meta::CPAN
The subroutine is completely obliterated from the
symbol table (though there may be
references to it elsewhere, including in compiled code).
=head1 PREREQUISITES
This module requires L<perl> 5.8.3 or higher.
=head1 LIMITATIONS
If you take a reference to a glob containing a subroutine, and then delete
the subroutine with C<delete_sub>, you will find that the glob you
referenced still has a subroutine in it. This is because C<delete_sub>
removes a glob, replaces it with another, and then copies the contents of
the old glob into the new one, except for the C<CODE> slot. (This is nearly
impossible to fix without breaking constant::lexical.)
=head1 FUNCTIONS
=head2 * delete_sub
=head2 * strict_eval
=head1 HOMEPAGE
lib/Sub/Delete.pm view on Meta::CPAN
=head1 SOURCE
Source repository is at L<https://github.com/perlancar/perl-Alt-Sub-Delete-NewPackageSeparator>.
=head1 SEE ALSO
L<perltodo>, which has C<delete &sub> listed as a possible future feature
L<Symbol::Glob> and L<Symbol::Util>, both of which predate this module (but
I only discovered them recently), and which allow one to delete any
arbitrary slot from a glob. Neither of them takes perl 5.10 constants
into account, however. They also both differ from this module, in that a
subroutine referenced in compiled code can no longer be called if deleted
from its glob. The entire glob must be replaced (which this module does).
=head1 AUTHOR & COPYRIGHT
Copyright (C) 2008-10 Father Chrysostomos (sprout at, um, cpan dot org)
This program is free software; you may redistribute or modify it (or both)
under the same terms as perl.
=head1 AUTHOR
t/Test/Builder.pm view on Meta::CPAN
=item B<new>
my $Test = Test::Builder->new;
Returns a Test::Builder object representing the current state of the
test.
Since you only run one test per program C<new> always returns the same
Test::Builder object. No matter how many times you call new(), you're
getting the same object. This is called a singleton. This is done so that
multiple modules share such global information as the test counter and
where test output is going.
If you want a completely new Test::Builder object different from the
singleton, use C<create>.
=cut
my $Test = Test::Builder->new;
sub new {
my($class) = shift;
t/Test/Builder.pm view on Meta::CPAN
Mostly useful for tests run in persistent environments where the same
test might be run multiple times in the same process.
=cut
use vars qw($Level);
sub reset {
my ($self) = @_;
# We leave this a global because it has to be localized and localizing
# hash keys is just asking for pain. Also, it was documented.
$Level = 1;
$self->{Test_Died} = 0;
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Original_Pid} = $$;
share($self->{Curr_Test});
$self->{Curr_Test} = 0;
t/Test/Builder.pm view on Meta::CPAN
}
return $fh;
}
sub _is_fh {
my $maybe_fh = shift;
return 0 unless defined $maybe_fh;
return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
return UNIVERSAL::isa($maybe_fh, 'GLOB') ||
UNIVERSAL::isa($maybe_fh, 'IO::Handle') ||
# 5.5.4's tied() and can() doesn't like getting undef
UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
}
sub _autoflush {
t/Test/Builder/Module.pm view on Meta::CPAN
my $builder = Your::Class->builder;
This method returns the Test::Builder object associated with Your::Class.
It is not a constructor so you can call it as often as you like.
This is the preferred way to get the Test::Builder object. You should
I<not> get it via C<< Test::Builder->new >> as was previously
recommended.
The object returned by builder() may change at runtime so you should
call builder() inside each function rather than store it in a global.
sub ok {
my $builder = Your::Class->builder;
return $builder->ok(@_);
}
=cut
t/Test/More.pm view on Meta::CPAN
Similar to is(), except that if $this and $that are references, it
does a deep comparison walking each data structure to see if they are
equivalent. If the two structures are different, it will display the
place where they start differing.
is_deeply() compares the dereferenced values of references, the
references themselves (except for their type) are ignored. This means
aspects such as blessing and ties are not considered "different".
is_deeply() current has very limited handling of function reference
and globs. It merely checks if they have the same referent. This may
improve in the future.
Test::Differences and Test::Deep provide more in-depth functionality
along these lines.
=cut
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
sub is_deeply {
{package Phoo;
sub thing {}
++$thing[0];
sub foo {}
()=\&bar;
use constant baz => 'dotodttoto';
}
is +()=delete_sub('thing'), 0, 'no retval';
ok !exists &{'thing'}, 'glob / sub that shares its symbol table entry';
is ${'thing'}[0], 1, 'the array in the same glob was left alone';
delete_sub 'foo';
ok !exists &{'foo'}, 'sub that has its own symbol table entry';
delete_sub 'bar';
ok !exists &{'bar'}, 'stub';
delete_sub 'baz';
ok !exists &{'baz'}, 'constant';
delete_sub 'Phoo::thing';
ok !exists &{'Phoo::thing'},
'sub in another package that shares its symbol table entry';
is ${'Phoo::thing'}[0], 1,
'the array in the same glob (in the other package) was left alone';
delete_sub 'Phoo::foo';
ok !exists &{'Phoo::foo'},
'sub in another package w/its own symbol table entry';
delete_sub 'Phoo::bar';
ok !exists &{'Phoo::bar'}, 'stub in another package';
delete_sub 'Phoo::baz';
ok !exists &{'Phoo::baz'}, 'constant in another package';
@ISA = 'Foo';
{no warnings qw 'once';
*Foo::thing = *Foo::foo = *Foo::bar = *Foo::baz = sub {1};}
# Make sure there really are no stubs left that would affect methods:
ok +main->$_, 'it really *has* been deleted'
for qw w thing foo bar baz w;
# Make sure that globs get erased if they exist solely for the sake of
# subroutines.
sub clext;
delete_sub 'clext';
ok !exists $::{clext},
'delete_subs deletes globs that exists solely for subroutines’ sake';
sub blile;
$blor = \$blile;
delete_sub 'blile';
cmp_ok $blor, '==', \${'blile'},
'delete_sub leaves globs whose scalar entry is referenced elsewhere';
SKIP:{
skip 'unimplemented', 2;
# We can’t make these two work, because it would require preserving the
# glob, which stops constant::lexical from working (because compiled code
# references not the subroutine, but the glob containing it).
# This case seems impossible. A glob is a scalar that has magic
# that references the actual glob (GP). Calling undef *brox (which
# delete_sub does) actually swaps out the GP, replacing it with another
# $blun = *bri syntax creates a new scalar referencing the same
# GP. There seems to be no way to make this work (from Perl at least;
# maybe we could do this with XS).
sub cho;
$belp = *cho;
delete_sub 'cho';
# $belp is now a different scalar from *cho, though it (ideally) shares
# the same magic object. So we have to test the equality by modifying it.
() = @$belp; # auto-vivify
cmp_ok \@$belp, '==', \@{'cho'},
'and globs that are themselves referenced elsewhere (via *bue syntax)';
sub ched;
$blode = \*ched;
delete_sub 'ched';
cmp_ok $blode, '==', \*{'ched'},
'and globs that are themselves referenced elsewhere (via \*bue syntax)';
}
# Make sure ‘use vars’ info is preserved.
{ package gred; *'chit = \$'chit } # use vars
sub chit;
delete_sub 'chit';
{
use strict 'vars';
ok eval q/()=$chit; 1/, '‘use vars’ flags are not erased';
}
# Make sure ‘use vars’ is not inadvertently turned on.
() = @glob; # auto-viv
sub glob; # We are calling this ‘glob’ as there is a lexical var in
delete_sub 'glob'; # delete_sub and we are making sure it doesn’t
{ # interfere.
use strict 'vars';
local $SIG{__WARN__} = sub {};
ok !eval q/()=$glob; 1/,
'‘use vars’ flags are not inadvertently turned on';
}
# Make sure we can run deleted subroutines
sub bange { 3 }
is eval { bange }, 3, 'deleted subroutines can be called';
BEGIN { delete_sub 'bange' }
# %^H leakage in perl 5.10.0
{
( run in 0.822 second using v1.01-cache-2.11-cpan-49f99fa48dc )