—

              
package Devel::Dumpvar;
# Devel::Dumpvar is a pure-OO re-implementation of the dumpvar.pl
# script used with the perl debugger.
# This module accepts that this will be slower than the original,
# but is designed to be easier to use, more accessible, and more
# upgradable without upgrading perl itself.
use 5.006;
use strict;
use Scalar::Util 1.18 ();
use vars qw{$VERSION};
BEGIN {
        $VERSION = '1.06';
}
#####################################################################
# Constructor and Accessors
sub new {
        my $class   = shift;
        my %options = @_;
        # Create the basic object
        my $self = bless {}, $class;
        # Handle the various options
        if ( defined $options{to} ) {
                $self->to( $options{to} );
        }
        $self;
}
sub to {
        my $self = shift;
        # Just return if no argument
        return $self->{to} unless @_;
        # If passed undef, print to STDOUT
        my $to = shift;
        unless ( defined $to ) {
                delete $self->{to};
                delete $self->{return};
                return 1;
        }
        # Is it something we can print to
        if ( Scalar::Util::blessed($to) and $to->can('print') ) {
                $self->{to} = $to;
                return 1;
        }
        # Handle the magic 'return' option
        if ( ! ref $to and $to eq 'return' ) {
                $self->{to}     = 'return';
                return 1;
        }
        # Unknown option
        die "Unknown value '$to' for 'to' options";
}
#####################################################################
# Dumping Methods
# Single method dumping
sub dump {
        my $self = ref $_[0] ? shift : shift->new;
        # Set up for dumping
        $self->{indent} = '';
        $self->{seen}   = {};
        $self->{return} = '' if $self->_return;
        if ( @_ ) {
                # Hand off to the array dumper
                $self->_dump_array( [ @_ ] );
        } else {
                # Shortcut the "no arguments" case
                $self->_print( "   empty array");
        }
        # Clean up and return the data if needed
        delete $self->{indent};
        delete $self->{seen};
        $self->_return ? delete $self->{return} : 1;
}
sub _dump_scalar {
        my $self  = shift;
        my $value = shift;
        # Print the printable form of the scalar
        $self->_print( "$self->{indent}-> " . $self->_scalar($$value) );
}
sub _dump_ref {
        my $self  = shift;
        my $value = ${shift()};
        # Print the current line
        $self->_print( "$self->{indent}-> " . $self->_refstring($value) );
        # Decend to the child reference
        $self->_dump_child( $value );
}
sub _dump_array {
        my $self      = shift;
        my $array_ref = shift;
        # Handle the null array
        unless ( @$array_ref ) {
                return $self->_print( $self->{indent} . "  empty array" );
        }
        for ( my $i = 0; $i <= $#$array_ref; $i++ ) {
                my $value = $array_ref->[$i];
                # Handle scalar values
                unless ( ref $value ) {
                        # Get the printable form of the scalar
                        $self->_print( "$self->{indent}$i  " . $self->_scalar($value) );
                        next;
                }
                # Print the array line
                $self->_print( "$self->{indent}$i  " . $self->_refstring($value) );
                # Descend to the child
                $self->_dump_child( $value );
        }
}
sub _dump_hash {
        my $self     = shift;
        my $hash_ref = shift;
        foreach my $key ( sort keys %$hash_ref ) {
                my $value = $hash_ref->{$key};
                # Handle scalar values
                unless ( ref $value ) {
                        # Get the printable form of the scalar
                        $self->_print( "$self->{indent}$key => " . $self->_scalar($value) );
                        next;
                }
                # Print the array line
                $self->_print( "$self->{indent}$key => " . $self->_refstring($value) );
                # Decent to the child
                $self->_dump_child( $value );
        }
}
sub _dump_code {
        my $self  = shift;
        $self->_print( "$self->{indent}-> Sub detail listing unsupported" );
}
sub _dump_child {
        my $self  = shift;
        my $value = ref $_[0] ? shift
                : die "Bad argument to _dump_child";
        # Regexp are a special case, they are immune
        # from the normal re-used address rules
        if ( ref $value eq 'Regexp' ) {
                # Print the pointer to the regexp
                return $self->_print( "$self->{indent}   -> qr/$value/" );
        }
        # Handle re-used addresses
        my $addr = Scalar::Util::refaddr $value;
        if ( $self->{seen}->{$addr}++ ) {
                # We've already seen this before
                return $self->_print( "$self->{indent}   -> REUSED_ADDRESS" );
        }
        # Indent to descend
        $self->{indent} .= '   ';
        # Split by type for the remaining items
        my $type = Scalar::Util::reftype $value;
        if ( $type eq 'REF' ) {
                $self->_dump_ref( $value );
        } elsif ( $type eq 'SCALAR' ) {
                $self->_dump_scalar( $value );
        } elsif ( $type eq 'ARRAY' ) {
                $self->_dump_array( $value );
        } elsif ( $type eq 'HASH' ) {
                $self->_dump_hash( $value );
        } elsif ( $type eq 'CODE' ) {
                $self->_dump_code( $value );
        } else {
                warn "ARRAY -> $type not supported";
        }
        # Remove indent
        $self->{indent} =~ s/   $//;
}
#####################################################################
# Support Methods
# Get the display string for a scalar value
sub _scalar {
        my $self = shift;
        my $v    = shift;
        # Shortcuts
        return 'undef' unless defined $v;
        return "''"    unless length  $v;
        # Is it a number?
        if ( Scalar::Util::looks_like_number($v) ) {
                # Show as-is
                return $v;
        }
        # Auto-detect the tick to use
        my $tick = "'";
        if ( ord('A') == 193 ) {
                if ( $v =~ /[\000-\011]/ or $v =~ /[\013-\024\31-\037\177]/ ) {
                        $tick = '"';
                } else {
                        $tick = "'";
                }
        } else {
                if ( $v =~ /[\000-\011\013-\037\177]/ ) {
                        $tick = '"';
                } else {
                        $tick = "'";
                }
        }
        # Tick-specific escaping
        if ( $tick eq "'" ) {
                $v =~ s/([\'\\])/\\$1/g;
        } else {
                $v =~ s/([\"\\\$\@])/\\$1/g;
                $v =~ s/\033/\\e/g;
                if ( ord('A') == 193 ) { # EBCDIC.
                        $v =~ s/([\000-\037\177])/'\\c'.chr(193)/eg; # Unfinished.
                } else {
                        $v =~ s/([\000-\037\177])/'\\c'._scalar_ord($1)/eg;
                }
        }
        # Unicode and high-bit escaping
        $v = _scalar_unicode($v);
        $v =~ s/([\200-\377])/'\\'.sprintf('%3o',ord($1))/eg;
        return "${tick}${v}${tick}";
}
sub _scalar_ord {
        my $chr = shift;
        $chr = chr(ord($chr)^64);
        $chr =~ s{\\}{\\\\}g;
        return $chr;
}
sub _scalar_unicode {
        join( "",
        map { $_ > 255 ? sprintf("\\x{%04X}", $_) : chr($_) }
        unpack("U*", $_[0]));
}
sub _refstring {
        my $self = shift;
        my $value = ref $_[0] ? shift
                : die "Bad argument to _refstring";
        # Handle regexp
        if ( ref $value eq 'Regexp' ) {
                return "$value";
        }
        my $addr  = sprintf '0x%x', Scalar::Util::refaddr($value);
        my $type  = Scalar::Util::reftype($value);
        unless ( $type =~ /^(?:SCALAR|ARRAY|HASH|REF|CODE)$/ ) {
                return "UNSUPPORTED($addr)";
        }
        my $class = Scalar::Util::blessed($value);
        defined $class
                ? "$class=$type($addr)"
                : "$type($addr)";
}
sub _print {
        my $self = shift;
        my $line = defined $_[0] ? "$_[0]\n" : "\n";
        # Handle the default case
        return print $line unless $self->{to};
        if ( $self->{to} eq 'return' ) {
                # Handle the "return data" case
                $self->{return} .= $line;
        } elsif ( Scalar::Util::blessed($self->{to}) and $self->{to}->can('print') ) {
                # If we have a we something we can print to, do so
                $self->{to}->print( $line );
        } else {
                # If the dump target is unknown, do nothing
        }
        1;
}
# Are we returning the dump data
sub _return {
        my $self = shift;
        defined $self->{to} and ! ref $self->{to} and $self->{to} eq 'return';
}
1;
__END__
HideShow 102 lines of Pod
=pod
=head1 NAME
Devel::Dumpvar - A pure-OO reimplementation of dumpvar.pl
=head1 SYNOPSIS
  use Devel::Dumpvar;
   
  # Dump something immediately to STDOUT
  Devel::Dumpvar->dump( [ 'foo' ], $bar' );
   
  # Create a dump handle to use repeatedly
  my $Dump = Devel::Dumpvar->new;
   
  # Dump via the handler
  $Dump->dump( 'foo', [ 'bar' ] );
=head1 DESCRIPTION
Most perl dumping modules are focused on serializing data structures
into a format that can be rebuilt into the original data structure.
They do this with a variety of different focuses, such as human
readability, the ability to execute the dumped code directly, or
to minimize the size of the dumped data.
Excect for the one contained in the debugger, in the file dumpvar.pl.
This is a much more human-readable form, highly useful for debugging,
containing a lot of extra information without the burden of needing to
allow the dump to be re-assembled into the original data.
The main downside of the dumper in the perl-debugger is that the
dumpvar.pl script is not really a readily loadable and useable module.
It has dedicated hooks from and to the debugger, and spans across
multiple namespaces, including main::.
Devel::Dumpvar is a pure object-orientated reimplementation of the
same functionality. This makes it much more versatile version to use
for dumping information to debug log files or other uses where you
don't need to reassemble the data.
=head1 METHODS
=head2 new( option => value, ... )
The C<new> constructor creates a new dumping object. Any options can
be passed a list of key/value pairs.
Each option passed to the constructor is set via one of the option
methods below.
=head2 to( $output_destination )
The C<to> option specifies where the output is to be sent to. When
undefined, output will go to STDOUT. The output destination can be
either a handle object ( or anything else with a ->print method ),
or the string 'return', which will cause the C<dump> method to collect
and return the dump results for each call, rather than printing it
immediately to the output.
If called without an argument, returns the current value.
If called with an argument, returns true or dies on error.
=head2 dump( data1, data2, ... )
If called as an object method, dumps a number of data values or structs
to the dumping object. If called as a class method, creates a new
default dump object and immediately dumps to it, destroying the dumper
afterwards.
=head1 TO DO
  - Implement options currently available in other dumpers as needed.
   
  - Currently only supports SCALAR, REF, ARRAY, HASH and Regexp.
    Add support for all possible reference types.
=head1 SUPPORT
Bugs should be reported via the CPAN bug tracker at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Devel-Dumpvar>
For other issues, or commercial enhancement or support, contact the author.
=head1 AUTHORS
Adam Kennedy E<lt>adamk@cpan.orgE<gt>
=head1 COPYRIGHT
Copyright 2004 - 2010 Adam Kennedy.
This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
The full text of the license can be found in the
LICENSE file included with this module.
=cut