File Coverage

blib/lib/Data/Dumper/EasyOO.pm

Criterion	Covered	Total	%
statement	131	135	97.0
branch	47	54	87.0
condition	12	14	85.7
subroutine	18	18	100.0
pod	3	3	100.0
total	211	224	94.2

#!perl

package Data::Dumper::EasyOO;
use Data::Dumper();
use Carp 'carp';
use strict;

use 5.005_03;
use vars qw($VERSION);
$VERSION = '0.0503';

=head1 NAME

Data::Dumper::EasyOO - wraps DD for easy use of various printing styles

=head1 ABSTRACT

EzDD is an object wrapper around Data::Dumper (henceforth just DD),
and uses an inner DD object to produce all its output.  Its purpose is
to make DD's OO capabilities easier to use, ie to make it easy to:

 1. label your data meaningfully, not just as $VARx
 2. make and reuse EzDD objects
 3. customize print styles on any/all of them independently
 4. provide essentially all of DD's functionality
 5. do so with fewest keystrokes possible

=head1 SYNOPSIS

1st, an equivalent to DD's Dumper, which prints exactly like Dumper does

    use Data::Dumper::EasyOO;
    print ezdump([1,3]);

which prints:

    $VAR1 = [
              1,
              3
            ];

Here, we provide our own (meaningful) label, and use autoprinting, and
thereby drop the 'print' from all ezdump calls.


    use Data::Dumper::EasyOO (autoprint => 1);
    my $gl = { Joe => 'beer', Betsy => 'wine' });
    ezdump ( guest_list => $gl);

which prints:

    $guest_list = {
                    'Joe' => 'beer',
                    'Betsy' => 'wine'
                  };


And theres much more...

=head1 DESCRIPTION

EzDD wraps Data::Dumper, and uses an inner DD object to print/dump.
By default the output is identical to DD.  That said, EzDD gives you a
nicer interface, thus encouraging you to tailor DD output the way you
like it.

A primary design feature of EzDD is that you can choose your preferred
printing style in the 'use' statement.  EzDD replaces the usual
'import' semantics with the same (property => value) pairs as are
available in new().

You can think of the use statement as a way to set new()'s default
behavior once, and reuse those styles (or override and supplement
them) on EzDD objects you create thereafter.

All of DD's style-setting methods are available in EzDD as both
properties to new(), and as object methods; its your choice.

=head2 An easy use of ezdump()

For maximum laziness support, ezdump() is exported into your
namespace, and supports the synopsis example.  $ezdump is also
exported; it is the EzDD object that ezdump() uses to do its dumping,
and allows you to tailor ezdump()s print-style.  It also lets you use
OO style if you prefer.

Continuing from 2nd synopsis example...

    $ezdump->Set(sortkeys=>1);
    ezdump ( guest_list => $gl );
    print "\n";
    $ezdump->Indent(1);
    ezdump ( guest_list => $gl );

which prints:

    $guest_list = {
                    'Betsy' => 'wine',
                    'Joe' => 'beer'
                  };

    $guest_list = {
      'Betsy' => 'wine',
      'Joe' => 'beer'
    };

The print-styles are set 2 times; 1st as a property setting, 2nd done
like a DD method.  The styles accumulate and persist on the object.


=cut

    ;
##############
# this (private) reference is passed to the closure to recover
# the underlying Data::Dumper object
my $magic = [];
my %cliPrefs;	# stores style preferences for each client package

# DD print-style options/methods/package-vars/attributes.
# Theyre delegated to the inner DD object, and 'importable' too.

my @styleopts;	# used to validate methods in Set()

# 5.00503 shipped with DD v2.101
@styleopts = qw( indent purity pad varname useqq terse freezer
		    toaster deepcopy quotekeys bless );

push @styleopts, qw( maxdepth )
    if $Data::Dumper::VERSION ge '2.102';	# with 5.6.1

push @styleopts, qw( pair useperl sortkeys deparse )
    if $Data::Dumper::VERSION ge '2.121';	# with 5.6.2

# DD methods; also delegated
my @ddmethods = qw ( Seen Values Names Reset );

# EzDD-specific importable style preferences
my @okPrefs = qw( autoprint init _ezdd_noreset );

##############
sub import {
    # save EzDD client's preferences for use in new()
    my ($pkg, @args) = @_;
    my ($prop, $val, %args);
    my ($alias, @aliases, @ezdds);
    my $caller = caller();

    # handle aliases, multiples allowed (feeping creaturism)

    foreach my $idx (grep {$args[$_] eq 'alias'} reverse 0..$#args) {
	($idx, $alias) = splice(@args, $idx, 2);
	no strict 'refs';
	*{$alias.'::new'} = \&{$pkg.'::new'};
	*{$alias.'::import'} = \&{$pkg.'::import'};
	push @aliases, $alias;
    }
    # quietly accept 'imports' of things we export anyway
    foreach my $idx (grep {$args[$_] =~ /[\$\&]?ezdump$/} reverse 0..$#args) {
	splice(@args, $idx, 1);
    }

    while ($prop = shift(@args)) {
	$val = shift(@args);

	if (not grep { $_ eq $prop} @styleopts, @okPrefs) {
	    carp "unknown print-style: $prop";
	    next;
	}
	elsif ($prop ne 'init') {
	    $args{$prop} = $val;
	    push @ezdds, $val;
	}
	else {
	    carp "init arg must be a ref to a (scalar) variable"
		unless ref($val) =~ /SCALAR/;

	    carp "wont construct a new EzDD object into non-undef variable"
		if defined $$val;

	    $$val = Data::Dumper::EasyOO->new(%args);
	}
    }
    $cliPrefs{$caller} = \%args;	# save the allowed ones

    # export ezdump() unconditionally
    # no warnings 'redefine';
    local $SIG{__WARN__} = sub {
	carp $@, @_ unless $_[0] =~ / redefined/;
    };
    no strict 'refs';
    my $ezdump = $pkg->new(%args);
    ${$caller.'::ezdump'} = $ezdump; # export $ezdump = \&ezdump
    *{$caller.'::ezdump'} = $ezdump; # export ezdump()

    return (1, \%args) if wantarray;
    return (\%args) if defined wantarray;
    return;
}

sub Set {
    # sets internal state of private data dumper object
    my ($ezdd, %cfg) = @_;
    my $ddo = $ezdd;
    $ddo = $ezdd->($magic) if ref $ezdd eq __PACKAGE__;

    $ddo->{_ezdd_noreset} = 1 if $cfg{_ezdd_noreset};

    for my $item (keys %cfg) {
	#print "$item => $cfg{$item}\n";
	my $attr = lc $item;
	my $meth = ucfirst $item;

	if (grep {$attr eq $_} @styleopts) {
	    $ddo->$meth($cfg{$item});
	}
	elsif (grep {$item eq $_} @ddmethods) {
	    $ddo->$meth($cfg{$item});
	}
	elsif (grep {$attr eq $_} @okPrefs) {
	    $ddo->{$attr} = $cfg{$item};
	}
	else { carp "illegal method <$item>" }
    }
    return $ezdd;
}

use vars '$AUTOLOAD';

sub AUTOLOAD {
    my ($ezdd, $arg) = @_;
    (my $meth = $AUTOLOAD) =~ s/.*:://;
    return if $meth eq 'DESTROY';
    my @vals = $ezdd->Set($meth => $arg);
    return $ezdd unless wantarray;
    return $ezdd, @vals;
}

sub pp {
    my ($ezdd, @data) = @_;
    $ezdd->(@data);
}

# Im ambivalent about this BEGIN block.  Its only use is to suppress
# redefined warnings issued when re-do{}'g the file, ie when purposely
# avoiding use or require (see t/redefined.t).  A more normal
# re-importing is already supressed in import(), by the same
# (localized) handler.

local $SIG{__WARN__};
BEGIN {
    $SIG{__WARN__} = sub {
	carp $@, @_ unless $_[0] =~ / redefined/;
    };
    *dump = \&pp;	# causes warning if done outside begin block
}

sub _ez_ddo {
    my ($ezdd) = @_;
    return $ezdd->($magic);
}

my $_privatePrinter;	# visible only to new and closure object it makes

sub new {
    my ($cls, %cfg) = @_;
    my $prefs = $cliPrefs{caller()} || {};

    my $ddo = Data::Dumper->new([]);	# inner obj w bogus data
    Set($ddo, %$prefs, %cfg);		# ctor-params override pkg-config

    #print "EzDD::new() ", Data::Dumper::Dumper [$prefs, \%cfg];

    my $code = sub { # closure on $ddo
	&$_privatePrinter($ddo, @_);
    };
    # copy constructor
    bless $code, ref $cls || $cls;

    if (ref $cls) {
	# clone its settings
	my $ddo = $cls->($magic);
	my %styles;
	@styles{@styleopts,@okPrefs} = @$ddo{@styleopts,@okPrefs};
	$code->Set(%styles,%cfg);
    }
    return $code;
}

$_privatePrinter = \&__DONT_TOUCH_THIS;

sub __DONT_TOUCH_THIS {
    my ($ddo, @args) = @_;

    unless ($ddo->{_ezdd_noreset}) {
	$ddo->Reset;	# clear seen
	$ddo->Names([]);	# clear labels
	$ddo->Values([]);	# clear data
    }
    if (@args == 1) {
	# test for AUTOLOADs special access
	return $ddo if defined $args[0] and $args[0] == $magic;

	# else Regular usage
	$ddo->{todump} = \@args;
    }
    elsif (@args % 2) {
	# cant be a hash, must be array of data
	$ddo->{todump} = \@args;
    }
    else {
	# possible labelled usage,
	# check that all 'labels' are scalars

	my %rev = reverse @args;
	if (grep {ref $_} values %rev) {
	    # odd elements are refs, must print as array
	    $ddo->{todump} = \@args;
	}
	else {
	    while (@args) {
		push @{$ddo->{names}}, shift @args;
		push @{$ddo->{todump}}, shift @args;
	    }
	}
    }
  PrintIt:
    # return dump-str unless *void* context
    return $ddo->Dump() if defined wantarray;

    unless (defined $ddo->{autoprint}) {
	carp "called in void context, without autoprint defined\n";
	return;
    }
    my $auto = $ddo->{autoprint};
    # do nothing if autoprint is 0
    return unless $auto;

    # autoprint to STDOUT, STDERR, or HANDLE (IO or GLOB)

    if (ref $auto and (ref $auto eq 'GLOB' or $auto->can("print"))) {
	print $auto $ddo->Dump();
    }
    elsif ($auto == 1) {
	print STDOUT $ddo->Dump();
    }
    elsif ($auto == 2) {
	print STDERR $ddo->Dump();
    }
    else {
	carp "illegal autoprint value: $ddo->{autoprint}";
    }
    return;
};


1;

__END__