File Coverage

blib/lib/Devel/Dumpvar.pm

Criterion	Covered	Total	%
statement	112	137	81.7
branch	44	70	62.8
condition	3	12	25.0
subroutine	18	20	90.0
pod	3	3	100.0
total	180	242	74.3

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__