Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options

Re^2: RFC: Acme::ExceptionEater

by itub (Priest)
on Sep 11, 2007 at 13:50 UTC ( #638302=note: print w/replies, xml ) Need Help??

in reply to Re: RFC: Acme::ExceptionEater
in thread RFC: Acme::ExceptionEater

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

Replies are listed 'Best First'.
Re^3: RFC: Acme::ExceptionEater
by TGI (Parson) on Sep 11, 2007 at 16:55 UTC

    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

      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).

      - tye        

        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.

        TGI says moo

      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.

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: note [id://638302]
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others examining the Monastery: (4)
As of 2021-04-15 06:07 GMT
Find Nodes?
    Voting Booth?

    No recent polls found