Beefy Boxes and Bandwidth Generously Provided by pair Networks
There's more than one way to do things
 
PerlMonks  

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


Comment on Re^2: RFC: Acme::ExceptionEater
Re^3: RFC: Acme::ExceptionEater
by TGI (Vicar) 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?
Username:
Password:

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

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (8)
As of 2015-07-03 17:54 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









    Results (55 votes), past polls