File Coverage

blib/lib/UNIVERSAL/dump.pm

Criterion	Covered	Total	%
statement	36	36	100.0
branch	18	18	100.0
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	60	60	100.0

package UNIVERSAL::dump;

# version info
$VERSION= '0.10';

# be as strict and verbose as possible
use strict;
use warnings;

# presets
my %preset= (
 blessed => 'Scalar::Util::blessed',
 dump    => 'Data::Dumper::Dumper',
 peek    => 'Devel::Peek::Dump',
 refaddr => 'Scalar::Util::refaddr',
);

# installed handlers
my %installed;

# satisfy require
1;

#-------------------------------------------------------------------------------
#
# Perl specific subroutines
#
#-------------------------------------------------------------------------------
#  IN: 1 class (ignored)
#      2..N method => subroutine pairs

sub import {
    my $class= shift;

    # make sure default is set
    unshift( @_,'dump' ) unless @_;

    # allow for redefining subroutines
    no warnings 'redefine';

    # handle all simple specifications
  METHOD:
    foreach my $spec (@_) {
        if ( !ref($spec) ) {
            die qq{Don't know how to install method "UNIVERSAL::$spec"\n}
              unless my $sub= $preset{$spec};
            $class->import( { $spec => $sub } );
            next METHOD;
        }

        # all methods
        foreach my $method ( keys %{$spec} ) {
            my $sub= $spec->{$method};
            $sub= $preset{$sub} if $preset{$sub};

            # already installed
            if ( my $installed= $installed{$method} ) {
                die qq{Cannot install "UNIVERSAL::$method" with "$sub":}
                    . qq{ already installed with "$installed"\n}
                  if $sub ne $installed;
            }

            # mark method as installed
            ( my $module= $sub ) =~ s#::[^:]+$##;
            $module =~ s#::#/#;
            $module .= ".pm";
            $installed{$method}= $sub;

            # install the method in the indicated namespace
            no strict 'refs';
            *{"UNIVERSAL::$method"}= sub {
                my $self = shift;
                eval { require $module };
                return $sub->( @_ ? @_ : $self ) if defined wantarray;
                print STDERR $sub->( @_ ? @_ : $self );
            } #UNIVERSAL::$method
        }
    }
} #import

#---------------------------------------------------------------------------

__END__