in reply to Exported subroutine redefine

Thank you all who responded with constructive suggestions. Apart from learning a great deal about perl internals, I like the result so much that I figured I'll share it with you. Criticism always welcome!
The goal was to seamlessly integrate OO exception handling with minimal effort from the user, and make the object smart enough to preserve as much information as possible along the way.

What this module can do:


The Module
# 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;
Update: Fix stringification problems.
Update2: Fix the fix :)

Replies are listed 'Best First'.
Re^2: Exported subroutine redefine
by shmem (Chancellor) on Nov 11, 2007 at 22:59 UTC
    Nice, but... now seeing the big picture and noting that it's not a general "global subroutine override" problem, but just about Carp - what about writing your own version of Carp.pm and including its path in PERL5LIB? Seems much easier and cleaner to me.

    --shmem

    _($_=" "x(1<<5)."?\n".q·/)Oo.  G°\        /
                                  /\_¯/(q    /
    ----------------------------  \__(m.====·.(_("always off the crowd"))."·
    ");sub _{s./.($e="'Itrs `mnsgdq Gdbj O`qkdq")=~y/"-y/#-z/;$e.e && print}
      Funny but I never thought of that :) So basically bring all the functionality described above plus the subroutines from Carp.pm, call the resulting module Carp.pm and load it from perl5lib while still relying on the original Carp::Heavy. Neat... Well at least I got pretty comfortable with the symbol table along the way :)