File Coverage

blib/lib/App/Framework/Base/Object/DumpObj.pm

Criterion	Covered	Total	%
statement	99	121	81.8
branch	39	52	75.0
condition			n/a
subroutine	15	18	83.3
pod	8	8	100.0
total	161	199	80.9

package App::Framework::Base::Object::DumpObj ;

=head1 NAME

App::Framework::Base::Object::DumpObj - Dump out an objects contents

=head1 SYNOPSIS

use App::Framework::Base::Object::DumpObj ;



=head1 DESCRIPTION

Given a data object (scalar, hash, array etc) prints out that objects contents


=head1 REQUIRES


=head1 DIAGNOSTICS

Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.

=head1 AUTHOR

Steve Price C<<  >>

=head1 BUGS

None that I know of!

=head1 INTERFACE

=over 4

=cut

use strict ;
use Carp ;
use Cwd ;


our $VERSION = "2.002" ;

require Exporter ;
our @ISA = qw(Exporter);
our @EXPORT =qw(
);

our @EXPORT_OK	=qw(
	prt_data
	prtstr_data
	exclude

	debug
	verbose

	$DEBUG
	$VERBOSE
	$PRINT_OBJECTS
	$PREFIX
);


#============================================================================================
# USES
#============================================================================================


#============================================================================================
# GLOBALS
#============================================================================================

our $DEBUG = 0 ;
our $VERBOSE = 0 ;
our $PRINT_OBJECTS = 0 ;
our $QUOTE_VALS = 0 ;
our $PREFIX = 0 ;

my $level ;
my %already_seen ;
my $prt_str ;
my %excludes ;


#============================================================================================
# EXPORTED
#============================================================================================

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

=item B

Set debug print options to B<$level>.

 0 = No debug
 1 = standard debug information
 2 = verbose debug information

=cut

sub debug
{
	my ($flag) = @_ ;

	my $old = $DEBUG ;

	if (defined($flag))
	{
		# set this module debug flag & sub-modules
		$DEBUG = $flag ;
	}
	return $old ;
}

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

=item B

Set vebose print options to B<$level>.

 0 = Non verbose
 1 = verbose print

=cut

sub verbose
{
	my ($flag) = @_ ;

	my $old = $VERBOSE ;

	if (defined($flag))
	{
		# set this module verbose flag & sub-modules
		$VERBOSE = $flag ;
	}
	return $old ;
}


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

=item B

Set option for printing out objects to B<$flag>.

 0 = Do not print contents of object [DEFAULT]
 1 = print contents of object

=cut

sub print_objects_flag
{
	my ($flag) = @_ ;

	my $old = $PRINT_OBJECTS ;

	if (defined($flag))
	{
		# set this module debug flag & sub-modules
		$PRINT_OBJECTS = $flag ;
	}
	return $old ;
}


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

=item B

Set option quoting the values to B<$flag>.

 0 = Do not quote values [DEFAULT]
 1 = Print values inside quotes

This is useful for re-using the output directly to define an array/hash

=cut

sub quote_vals_flag
{
	my ($flag) = @_ ;

	my $old = $QUOTE_VALS ;

	if (defined($flag))
	{
		# set this module debug flag & sub-modules
		$QUOTE_VALS = $flag ;
	}
	return $old ;
}

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

=item B

Set the list of excluded HASH keys. Any keys in a HASH that match the name(s) in the list will not be
displayed.

Specifying an empty list clears the excludes

=cut

sub exclude
{
	my (@list) = @_ ;

	%excludes = () ;
	%excludes = map {$_ => 1} @list ;

	return  ;
}

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

=item B

Prefix all output lines with B<$prefix>

Returns previous value

=cut

sub prefix
{
	my ($prefix) = @_ ;

	my $old = $PREFIX ;

	if (defined($prefix))
	{
		# set this module debug flag & sub-modules
		$PREFIX = $prefix ;
	}
	return $old ;
}



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

=item B

Create a multiline string of all items in the list. Handles scalars, hashes (as an array),
arrays, ref to scalar, ref to hash, ref to array, object.

=cut

sub prtstr_data
{
	my (@data_list) = @_ ;

	$level = -1 ;
	%already_seen = () ;
	$prt_str = '' ;

	foreach my $var (@_)
	{
	   if (ref ($var))
	   {
	       _print_ref($var);
	   }
	   else
	   {
	       _print_scalar($var);
	   }
	}

	return $prt_str ;
}

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

=item B

Print out each item in the list. Handles scalars, hashes (as an array),
arrays, ref to scalar, ref to hash, ref to array, object.

=cut

sub prt_data
{
	my (@data_list) = @_ ;

	prtstr_data(@data_list) ;
	print $prt_str ;

}



# ============================================================================================
# UNEXPORTED BY DEFAULT
# ============================================================================================

#---------------------------------------------------------------------------------------------------
sub _print_scalar
{
    ++$level;
    _print_indented ($_[0]);
    --$level;
}

#---------------------------------------------------------------------------------------------------
sub _print_ref
{
    my $r = $_[0];

    if (!defined($r))
	{
        _print_indented ("undef\n");
        return;
    }
    elsif (exists ($already_seen{$r}))
	{
        _print_indented ("# $r (Seen earlier)\n");
        return;
    }
	else
	{
        $already_seen{$r}=1;
    }

    my $ref_type = ref($r);

    if ($ref_type eq "ARRAY")
	{
        _print_array($r);
    }
	elsif ($ref_type eq "SCALAR")
	{
        _print_scalar($$r);
        _print_str(" # Ref -> $r\n");
    }
	elsif ($ref_type eq "HASH")
	{
        _print_hash($r);
    }
	elsif ($ref_type eq "REF")
	{
        ++$level;
        _print_indented("# Ref -> ($r)\n");
        _print_ref($$r);
        --$level;
    }
	else
	{
        _print_indented ("# OBJECT $ref_type\n");

		# If required (and we can) print out the object
		if ($PRINT_OBJECTS)
		{
			my $obj_ref_str = "$r" ;
			if ($obj_ref_str =~ /ARRAY/)
			{
			   _print_array($r);
			}
			elsif ($obj_ref_str =~ m/HASH/)
			{
			   _print_hash($r);
			}
		}
    }
}

#---------------------------------------------------------------------------------------------------
sub _print_array
{
    my ($r_array) = @_;

    ++$level;
    _print_indented ("[ # $r_array\n");
    foreach my $var (@$r_array)
	{
        if (ref ($var))
		{
            _print_ref($var);
        }
		else
		{
            _print_scalar($var);
            _print_str(",\n");
        }
    }
    _print_indented ("],\n");
    --$level;
}

#---------------------------------------------------------------------------------------------------
sub _print_hash
{
    my($r_hash) = @_;

    my($key, $val);
    ++$level;

    _print_indented ("{ # $r_hash\n");

#    while (($key, $val) = each %$r_hash)
	 foreach my $key (sort keys %$r_hash)
	 {
#print "<< key <$key> r_hash <$r_hash> >>\n" ;
	 	my $val = $r_hash->{$key} ;
	 	 if (defined($val))
		 {
	        $val = ($val ? $val : '0');
		 }
		 else
		 {
	        $val = 'undef' ;
		 }

        ++$level;

		if (exists($excludes{$key}))
		{
            _print_indented ("$key => ...\n");
		}
		else
		{
	        if (ref ($val))
			{
	            _print_indented ("$key => \n");
	            _print_ref($val);
	        }
			else
			{
	            _print_indented ("$key => $val,\n");
	        }
		}
        --$level;
    }
    _print_indented ("},\n");
    --$level;
}

#---------------------------------------------------------------------------------------------------
sub _print_indented
{
    my $spaces = "  " x $level;
    if ($PREFIX)
    {
    	# print prefix at start of a line
		if (!$prt_str)
		{
	    	_print_str("$PREFIX") ;
		}
		elsif ($prt_str =~ m/(.*)\n$/)
		{
	    	_print_str("$PREFIX") ;
		}
    }
    _print_str("${spaces}") ;
	_print_val($_[0]) ;
#    $prt_str .= "\n" ;
}


#---------------------------------------------------------------------------------------------------
sub _print_val
{
	my ($val) = @_ ;

	if (defined($val))
	{
		_print_str("$val") ;

		# Print positive numerical value in hex too
		if ($val =~ m/(^|\s+)(\d+)$/)
		{
		   _print_str(sprintf "  # [0x%0x]", $2) if ($2 > 0) ;
		}
	}
	else
	{
		_print_str("undef") ;
	}

}

#---------------------------------------------------------------------------------------------------
sub _print_str
{
	my ($str) = @_ ;

	$prt_str .= $str ;
}



# ============================================================================================
# END OF PACKAGE
1;

__END__