Re^2: RFC: Acme::ExceptionEater

[itub]

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! ;-)

[TGI]

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?

[tye]

You usually start in %main:: (which is also %::) and look for keys ending in "::" that have a hash entry defined and recurse (skipping over %main::main::, etc).

[TGI]

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;

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.

[kyle]

I got this with some monkeying around:

use Data::Dumper;
package Foo::Empty;
package Foo::OneVar;
$one_var = 'foo!';
package main;

my %done;
sub seek_destroy {
    my ( $name ) = @_;
    return if $done{$name}++;
    foreach my $package ( grep { /::$/ } keys %{$name} ) {
        print "$name$package\n";
        print "!!! $name$package" . "DESTROY!!\n"
            if exists ${"$name$package"}{DESTROY};   
        seek_destroy( "$name::$package" ) if defined $package;
    }
}

seek_destroy( 'main::' );

It finds both "Foo::OneVar" and "Foo::Empty", and it sees the DESTROY methods of Data::Dumper and main::Regex. It spews warnings like crazy, but I can polish that up later.