Source

p5-data-dumper-declare / lib / Data / Dumper / Declare.pm

Full commit
package Data::Dumper::Declare;

use 5.010;
use strict;
use warnings;
use utf8;

BEGIN {
	$Data::Dumper::Declare::AUTHORITY = 'cpan:TOBYINK';
	$Data::Dumper::Declare::VERSION   = '0.001';
}

use Carp;
use Data::Dumper;
use Devel::Declare          0.006007    ();
use Devel::Declare::Context::Simple   0 ();
use B::Hooks::EndOfScope    0.09;
use Sub::Install            0.925       qw(install_sub);

sub scalarify (_)
{
	my $_ = shift;
	if    (/^[\$\\]/)      { return $_ }
	elsif (/^[\@\%\&\*]/)  { return "\\$_" }
	else                   { return "scalar($_)" }
}

sub displayify (_)
{
	my $_ = shift;
	if    (/^[\$\\]/)      { return $_ }
	elsif (/^[\@\%\&\*]/)  { return "\\$_" }
	else                   { return "\$EXPR" }
}

use namespace::clean        0.19;

{
	package Data::Dumper::Declare::Parser;
	use base qw[Devel::Assert::Parser];

	use PPI;
	use PPI::Dumper;

	sub get_arg_list
	{
		my $parser = shift;
		
		my $args  = $parser->extract_args;
		my $doc   = PPI::Document->new(\$args)
			or Carp::croak("could not parse argument list");
		my $list  = $doc->find_first('Statement')
			or return;
		
		my @items;
		my $pos = 0;
		foreach my $child ($list->children)
		{
			next if $child->isa('PPI::Token::Whitespace');
			next if $child->isa('PPI::Token::Comment');
						
			if ("$child" eq ",")
			{
				++$pos;
				next;
			}
			
			$items[$pos] .= $child;
		}
		
		return @items;
	}
}

sub import
{
	my ($class, %args) = @_;
	my @NewOps = qw(Dumper);
	
	my $target = $args{-into} || caller;
	
	Devel::Declare->setup_for($target => {
		map {
			my $name = $_;
			($name => {
				const => sub {
					return $class->_transform($name, @_);
				},
			})
		} @NewOps
	});
	for my $name (@NewOps) {
		install_sub {
			into => $target,
			as   => $name,
			code => $class->_run_callback($name),
		}
	}
	on_scope_end {
		namespace::clean->clean_subroutines($target, @NewOps);
	};
	return 1;
}

sub _run_callback {sub
{
	my ($values, $names) = @_;
	local $Data::Dumper::Terse = 1;
	my @return;
	foreach my $i (0 .. $#$values)
	{
		my $dump = Data::Dumper::Dumper($values->[$i]);
		chomp $dump;
		push @return, sprintf("%s = %s;\n", $names->[$i], $dump);
	}
	
	wantarray ? @return : join(q() => @return);
}}
 
sub _transform
{
	my $class = shift;
	my $name  = shift;

	my $parser = Data::Dumper::Declare::Parser->new($_[1]);
	return if $parser->get_word ne $name;
	
	$parser->skip_word();
	$parser->skip_spaces();
	
	if ($parser->get_symbols(1) ne '(')
	{
		croak "You must only use Dumper as 'Dumper(expression)', failed";
	}
	
	my @list = $parser->get_arg_list;
	
	my @real_args    = map { scalarify } @list;
	my @display_args = map { displayify } @list;
	
	my $real_args    = join ',', @real_args;
	my $display_args = join ',', map { qq(q($_)) } @display_args;
	
	$parser->inject("([$real_args], [$display_args])");
}

__PACKAGE__
__END__

=head1 NAME

Data::Dumper::Declare - Data::Dumper, sweetened with Devel::Declare

=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 BUGS

Please report any bugs to
L<http://rt.cpan.org/Dist/Display.html?Queue=Data-Dumper-Declare>.

=head1 SEE ALSO

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2012 by Toby Inkster.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.


=head1 DISCLAIMER OF WARRANTIES

THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.