in reply to Exported subroutine redefine
will resut in $@ containing an object with 3 frames, each containing all information pertaining to the specific exception.eval { eval { Module::stuff(...); # this throws an exception } croak ($@, 'More info'); } die;
Update: Fix stringification problems.# package name can be anything, __PACKAGE__ is used throughout the mod +ule # subclassing is impractical and not implemented package PRD::Error; use warnings; use strict; use Carp qw//; use Data::Dumper; use base qw/Exporter/; # probably should write my own import() our @EXPORT = qw/die/; # and have :objectify as a flag to objectify C +arp use overload ( q/""/ => \&stringify, fallback => 1, ); # this die() will be imported into any package that uses us sub die (@) { # find the first caller outside of this package my $fr = 0; while (caller($fr) and __PACKAGE__ eq caller($fr)) { $fr++; } my @caller = caller($fr); my $eframe = { file => $caller[1], line => $caller[2], caller => 'die', }; my @err; if (@_) { #check for a pseudo-object created by UNIVERSAL::die #(recognized by being a hash instead of an array) if (ref $_[0] eq __PACKAGE__ and UNIVERSAL::isa ($_[0], 'HASH' +) ) { my $pseudo = shift; for (keys %$pseudo) { if ($_ eq 'error') { @err = @{$pseudo->{$_}}; } else { $eframe->{$_} = $pseudo->{$_}; } } } #check if we are called as a class method (package->die ()) elsif ($caller[0] eq $_[0] and (@_ > 1 or $@) ) { $eframe->{class} = shift; $eframe->{caller} = 'class'; } } # either remaining @_ or $@ or nothing unless (@err) { @err = @_ ? @_ : ($@ || () ); } my $eobj = []; # check if this is a re-thrown error object if (ref $err[0] eq __PACKAGE__) { $eobj = shift @err; } $eframe->{trace} ||= _trace (@err); if (@err) { $eframe->{error} = \@err; } push @$eobj, $eframe; CORE::die bless ($eobj, __PACKAGE__); } # teach objects how to die sub UNIVERSAL::die { my $obj = shift; # native object if (ref $obj eq __PACKAGE__) { &die ($obj, @_); } # foreign object else { my $pseudo = { caller => 'object', object => $obj, trace => _trace (@_), }; $pseudo->{error} = [ @_ ] if @_; &die (bless $pseudo, __PACKAGE__); } } sub stringify { my $self = shift; my $fr = shift || 0; # no stringification when called by _trace() return $self if (caller(1) and (caller(1))[3] eq __PACKAGE__ . ':: +_trace'); unless ($self->[$fr]) { CORE::die Carp::shortmess ( sprintf ( "Frame index '%s' requested from object with %d frames", $fr, scalar @$self, )); } my $err = ( $self->[$fr]{error} ) ? join '; ', @{$self->[$fr]{error}} : ''; if ($err !~ /\n$/ or grep { $self->[$fr]{caller} eq $_ } qw/confess croak/ ) { $err .= " at $self->[$fr]{file} line $self->[$fr]{line}.\n"; } if ($self->[$fr]{caller} eq 'confess') { $err .= join "\n", ( map { "\t$_" } (splice @{$self->[$fr]{trace}}, 1), '', ); } return $err; } # dumper shortcut sub dump { my $self = shift; return Dumper [ @$self ]; } # objectify Carp.pm exceptions globally { no warnings qw/redefine/; no strict qw/refs/; my %redef = ( croak => sub { my $pseudo = { error => [ @_ ], caller => 'croak', trace => _trace (@_), }; { local $Carp::CarpLevel = 1; ($pseudo->{file}, $pseudo->{line}) = Carp::shortmess ('') =~ /^ \s at \s (.+) \s line \ +s (\d+)/x; } &die (bless $pseudo, __PACKAGE__); }, confess => sub { my $pseudo = { error => [ @_ ], caller => 'confess', trace => _trace (@_), }; &die (bless $pseudo, __PACKAGE__); }, ); _redef(); sub _redef { my $parent = shift || '::'; for my $ns (grep /^\w+::/, keys %{$parent}) { $ns = $parent . $ns; _redef($ns) unless $ns eq '::main::'; for my $sub (keys %redef) { *{$ns . $sub} = $redef{$sub} if (exists ${$ns}{$sub}); } } } } # separate Carp::longmess into logical lines sub _trace { local $Carp::CarpLevel = 1; my @trace; my $mess = Carp::longmess (join '; ', @_); while ($mess =~ /\s* (.+? \s at \s [^\n]+? \s line \s \d+) \s*\n/x +mgs) { push @trace, $1; } return \@trace; } 1;
|
|---|
| Replies are listed 'Best First'. | |
|---|---|
|
Re^2: Exported subroutine redefine
by shmem (Chancellor) on Nov 11, 2007 at 22:59 UTC | |
by ribasushi (Pilgrim) on Nov 12, 2007 at 07:56 UTC |