I spent a bit more time googling and thinking about this and came up with this code.

use strict;
use warnings;




eval {
    my $f = Foo->new;
    die 'foo'
};
print "Test 1: $@\n";

eval {
    my $f = Foo->new;
    $f->die;
};

print "Test 2: $@\n";

print "Done\n";
exit;

package Foo;

sub new {
    bless {}, __PACKAGE__;
}

sub die { die "He's dead, Jim.\n" }

#sub DESTROY { 1; }

1;

package Bad;

use strict;
use warnings;

our %OMIT;
BEGIN {
    our @OMIT = (
        "Carp::", 
        "Carp::Heavy::", 
        "DynaLoader::", 
        "Internals::",
        "XSLoader::", 
        "CORE::",
        "CORE::GLOBAL::",  
        "UNIVERSAL::",
    );

    @OMIT{ @OMIT } = ();

}

# Pollute all namespaces
INIT {
    my %done; 

    for my $pkg ( scan( $main::{"main::"} ) ) { 

        next if $done{$pkg}++; 

        print "Eating $pkg\n";

        my $eater = $pkg . "DESTROY"; 
        my $orig= \&{$eater}; 

        next unless $orig;

        no warnings; 
        no strict 'refs';
        *{ "$eater" }= sub { 
            print "Ate $pkg\n"; 
            my @caller = caller(1);
            my @this   = caller(1);

            # Prevent infinite loops.
            my $same = 1;
            foreach ( 0..$#caller ) {
                $same = 0 if $caller[$_] ne $this[$_]
            }
            
            if ( $same ) {
                eval {};
            }
            else {
                $orig->(@_); eval{};
            }

        }
    } 
}


sub scan {
    my $start =  shift;
    my $prefix = shift;
    $prefix = '' unless defined $prefix;

    my @return;

    foreach my $key ( keys %{$start}){

        if ($key =~ /::$/){
            unless ($start  eq ${$start}{$key} or $key eq "B::" ){
                push @return, $key unless omit($prefix.$key);
                foreach my $subscan ( scan(${$start}{$key},$prefix.$ke
+y)){
                    push @return, "$key".$subscan;     
                }
            }
        }
    }

    return @return;
}

sub omit {
    my $module = shift;

    # Skip pragmata
    return 1 if $module eq "\l$module";

    return 1 
        if exists $OMIT{$module};

    # Skip preloaded IO modules
    if (
           $module eq "IO::" 
        or $module eq "IO::Handle::"
    ) {

        $module =~ s/::/\//g;    

        return 1 unless  $INC{$module};
    }

    return 0;
}

1;
[download]

The symbol table walking code is lifted from B::Stash. I left the B::Stash's omit list intact and added logic to skip pragmata. I don't understand 100% of what I am doing here--I still need to spend some time working on understanding the symbol tables and how to (ab)use them.

I had to put in an ugly little klduge to keep the code from going into an infinite loop when a DESTROY method is not defined for a package. I'm not sure why its needed, but I am sure there's a better way to do it.

I've already spent way too much time on this today. Anyhow in the next few days I'll be looking into this a bit deeper. This excuse to dig into the symbol tables is way too much fun.