File Coverage

blib/lib/Data/Printer.pm

Criterion	Covered	Total	%
statement	119	131	90.8
branch	45	66	68.1
condition	34	48	70.8
subroutine	15	15	100.0
pod	2	2	100.0
total	215	262	82.0

package Data::Printer;
use strict;
use warnings;
use Data::Printer::Object;
use Data::Printer::Common;
use Data::Printer::Config;

our $VERSION = '1.000004';
$VERSION = eval $VERSION;

my $rc_arguments;
my %arguments_for;

sub import {
    my $class = shift;

    _initialize();

    my $args;
    if (@_ > 0) {
        $args = @_ == 1 ? shift : {@_};
        Data::Printer::Common::_warn(
            undef,
            'Data::Printer can receive either a hash or a hash reference'
        ) unless ref $args eq 'HASH';
        $args = Data::Printer::Config::_expand_profile($args)
            if exists $args->{profile};
    }

    # every time you load it, we override the version from *your* caller
    my $caller = caller;
    $arguments_for{$caller} = $args;

    my $use_prototypes = _find_option('use_prototypes', $args, $caller, 1);
    my $exported = ($use_prototypes ? \&p : \&_p_without_prototypes);

    my $imported = _find_option('alias', $args, $caller, 'p');

    { no strict 'refs';
        *{"$caller\::$imported"} = $exported;
        *{"$caller\::np"}        = \&np;
    }
}

sub _initialize {
    # potential race but worst case is we read it twice :)
    { no warnings 'redefine'; *_initialize = sub {} }
    $rc_arguments = Data::Printer::Config::load_rc_file();
}

sub np (\[@$%&];%) {
    my (undef, %properties) = @_;

    _initialize();

    my $caller = caller;
    my $args_to_use = _fetch_args_with($caller, \%properties);
    my $printer = Data::Printer::Object->new($args_to_use);

    # force color level 0 on 'auto' colors:
    if ($printer->colored eq 'auto') {
        $printer->{_output_color_level} = 0;
    }

    my $ref = ref $_[0];
    if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF' && ref ${$_[0]} eq 'REF')) {
        $printer->{_refcount_base}++;
    }
    my $output = $printer->parse($_[0]);
    if ($printer->caller_message_position eq 'after') {
        $output .= $printer->_write_label;
    }
    else {
        $output = $printer->_write_label . $output;
    }
    return $output;
}


sub p (\[@$%&];%) {
    my (undef, %properties) = @_;

    _initialize();

    my $caller = caller;
    my $args_to_use = _fetch_args_with($caller, \%properties);
    my $printer = Data::Printer::Object->new($args_to_use);
    my $want_value = defined wantarray;
    if ($printer->colored eq 'auto' && $printer->return_value eq 'dump' && $want_value) {
        $printer->{_output_color_level} = 0;
    }

    my $ref = ref $_[0];
    if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF' && ref ${$_[0]} eq 'REF')) {
        $printer->{_refcount_base}++;
    }
    my $output = $printer->parse($_[0]);
    if ($printer->caller_message_position eq 'after') {
        $output .= $printer->_write_label;
    }
    else {
        $output = $printer->_write_label . $output;
    }

    return _handle_output($printer, $output, $want_value, $_[0]);
}

# This is a p() clone without prototypes. Just like regular Data::Dumper,
# this version expects a reference as its first argument. We make a single
# exception for when we only get one argument, in which case we ref it
# for the user and keep going.
sub _p_without_prototypes  {
    my (undef, %properties) = @_;

    my $item;
    if (!ref $_[0] && @_ == 1) {
        my $item_value = $_[0];
        $item = \$item_value;
    }

    _initialize();

    my $caller = caller;
    my $args_to_use = _fetch_args_with($caller, \%properties);
    my $printer = Data::Printer::Object->new($args_to_use);

    my $want_value = defined wantarray;
    if ($printer->colored eq 'auto' && $printer->return_value eq 'dump' && $want_value) {
        $printer->{_output_color_level} = 0;
    }

    my $ref = ref( defined $item ? $item : $_[0] );
    if ($ref eq 'ARRAY' || $ref eq 'HASH' || ($ref eq 'REF'
        && ref(defined $item ? $item : ${$_[0]}) eq 'REF')) {
        $printer->{_refcount_base}++;
    }
    my $output = $printer->parse((defined $item ? $item : $_[0]));
    if ($printer->caller_message_position eq 'after') {
        $output .= $printer->_write_label;
    }
    else {
        $output = $printer->_write_label . $output;
    }

    return _handle_output($printer, $output, $want_value, $_[0]);
}


sub _handle_output {
    my ($printer, $output, $wantarray, $data) = @_;

    if ($printer->return_value eq 'pass') {
        print { $printer->{output_handle} } $output . "\n";
        require Scalar::Util;
        my $ref = Scalar::Util::blessed($data);
        return $data if defined $ref;
        $ref = Scalar::Util::reftype($data);
        if (!$ref) {
            return $data;
        }
        elsif ($ref eq 'ARRAY') {
            return @$data;
        }
        elsif ($ref eq 'HASH') {
            return %$data;
        }
        elsif ( grep { $ref eq $_ } qw(REF SCALAR VSTRING) ) {
            return $$data;
        }
        else {
            return $data;
        }
    }
    elsif ($printer->return_value eq 'void' || !$wantarray) {
        print { $printer->{output_handle} } $output . "\n";
        return;
    }
    else {
        return $output;
    }
}

sub _fetch_args_with {
    my ($caller, $run_properties) = @_;

    my $args_to_use = {};
    if (keys %$rc_arguments) {
        $args_to_use = Data::Printer::Config::_merge_options(
            $args_to_use, $rc_arguments->{'_'}
        );
        if (exists $rc_arguments->{$caller}) {
            $args_to_use = Data::Printer::Config::_merge_options(
                $args_to_use, $rc_arguments->{$caller}
            );
        }
    }
    if ($arguments_for{$caller}) {
        $args_to_use = Data::Printer::Config::_merge_options(
            $args_to_use, $arguments_for{$caller}
        );
    }
    if (keys %$run_properties) {
        $run_properties = Data::Printer::Config::_expand_profile($run_properties)
            if exists $run_properties->{profile};
        $args_to_use = Data::Printer::Config::_merge_options(
            $args_to_use, $run_properties
        );
    }
    return $args_to_use;
}


sub _find_option {
    my ($key, $args, $caller, $default) = @_;

    my $value;
    if (exists $args->{$key}) {
        $value =  $args->{$key};
    }
    elsif (
          exists $rc_arguments->{$caller}
       && exists $rc_arguments->{$caller}{$key}
    ) {
        $value = $rc_arguments->{$caller}{$key};
    }
    elsif (exists $rc_arguments->{'_'}{$key}) {
        $value = $rc_arguments->{'_'}{$key};
    }
    else {
        $value = $default;
    }
    return $value;
}


'Marielle, presente.';
__END__