Why not take arguments in your use statement, and then inject an exception eating DESTROY method into any listed classes. Just pervert the code tye posted in response to you, et viola!

package Acme::ExceptionEater;
my %done; 

sub import { 
    shift @_; 
    for my $pkg ( @_ ) { 
        next if $done{$pkg}++; 
        $pkg .= "::DESTROY"; 
        my $orig= \&{$pkg}; 
        no warnings; 
        *{$pkg}= sub { $orig->(@_); eval{}; }
    } 
}
[download]

Warning: This is a totally untested copy/paste/perversion of tye's code.

Assuming I didn't break it, then you can do:

use Happy::Friendly::Package;
use Acme::ExceptionEater qw( Happy::Friendly::Package );
[download]

And you too will have mysteriously silent failures in your code!

Wow, TGI, I love that idea! I regret that I have but one vote to give for it. Thank you!

I don't think my mother wants me to play with you guys.

While you are at it, you could look at the symbol table and inject the exception-eating DESTROY into every package that happens to be loaded! ;-)

I was thinking about that yesterday, but I couldn't figure out where to look to get the required info in a reliable fashion.

The obvious place to look is in %INC. But that gives you munged names, and only on a per file included basis. Files that define multiple packages would not be handled properly.

Based on my investigation of perlguts and perlapi each namespace has a stash associated with it. So if you have a list of all the stashes, you can get their names, and if you have their names, you have all the namespaces you want to add a perverse DESTROY method to.

Do you have any idea where to find either a list of active namespaces or stashes?


TGI says moo

now we know what the phrase "evil hacker" really means... ;-]

Don Wilde
"There's more than one level to any answer."

This seems to do the automatic wrapping properly. It just needs some clean-up and modulification, and it should be ready to ruin the day of anyone foolish enough to use it.

use strict;

# Symbol table experiments.

use Data::Dumper;

#use Win32::SerialPort;

# All entries in symbol table are uniquely identified by a typeglob.
#print join "\n",
#    $::{'main::'},
#    $main::{'main::'},
#    $main::main::{'main::'},
#   $main::main::main::{'main::'},
#   ;

my %OMIT;
BEGIN {
    my @OMIT = qw( *main::UNIVERSAL:: );
    @OMIT{@OMIT} = ();
}



wrap_destroy($_) foreach find_namespaces( 'main::' );


eval {
    my $f = Foo->new();

    die 'adsfasdf';
};

eval {
    my $f = Foo::Foo->new();

    die 'adsfasdf';
};

eval {
    my $f = Foo::Foo::Foo->new();

    die 'adsfasdf';
};

eval {
    my $f = Foo::Foo::Bar->new();

    die 'adsfasdf';
};






sub find_namespaces {

    my $seen = 
        ref($_[0]) eq 'HASH'
        ? shift 
        : {} 
        ;

    my @names = @_;

    my @results;

    foreach my $name ( @names ) {
        no strict 'refs';
        foreach my $entry ( keys %{$name} ) {
            next unless $entry =~ /::$/;
            my $typeglob = ${$name}{$entry};

            next if $$seen{$typeglob}++;

            find_namespaces( $seen, $typeglob ); 
        }
    }

    return keys %$seen ;
}

sub has_destroy {
    my $namespace = shift;
    no strict 'refs';
    if ( exists ${$namespace}{DESTROY} ) {
        print "\t$namespace has DESTROY\n";
    }
}

sub inherits_destroy {
    my $namespace = shift;
    $namespace =~ s/^\*(main::)?//;
    $namespace =~ s/::$//;
    return UNIVERSAL::can( $namespace, 'DESTROY' );
}


sub wrap_destroy {
    my $namespace = shift;
        
    no warnings; 
    no strict 'refs';
    my $eater = $namespace . "DESTROY";

    return if exists $OMIT{$namespace};

    my $sub;
    if( has_destroy( $namespace ) ) {

        my $orig = \&{ ${$namespace}{DESTROY} };

        $sub = sub {
            print "$eater Ate $namespace\n"; 

            my @caller = caller(1);
            my @this   = caller(1);

            $orig->(@_); eval{};

        };
    }
    elsif ( inherits_destroy( $namespace ) ) {
            print "$namespace inherits DESTROY\n";;
    }
    else {
        print "$namespace has no DESTROY\n";;

        $sub = sub {
            print "$eater Swallowed $namespace\n"; 
            eval{};
        }
    }

    *{ "$eater" }= $sub;

}



package Foo;
sub new { bless {}, __PACKAGE__; }
sub DESTROY { 1; }

package Foo::Bar;
sub new { bless {}, __PACKAGE__; }
sub DESTROY { 1; }

package Foo::Foo;
sub new { bless {}, __PACKAGE__; }
sub DESTROY { 1; }

package Foo::Foo::Foo;
sub new { bless {}, __PACKAGE__; }
use base 'Foo::Foo';

package Foo::Foo::Bar;
sub new { bless {}, __PACKAGE__; }
[download]