File Coverage

blib/lib/Data/Printer.pm

Criterion	Covered	Total	%
statement	126	137	91.9
branch	49	72	68.0
condition	34	48	70.8
subroutine	16	16	100.0
pod	2	2	100.0
total	227	275	82.5

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

our $VERSION = '1.001000';
$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 {} }

    my $rc_filename = Data::Printer::Config::_get_first_rc_file_available();
    $rc_arguments = Data::Printer::Config::load_rc_file($rc_filename);

    if (
           exists $rc_arguments->{'_'}{live_update}
        && defined $rc_arguments->{'_'}{live_update}
        && $rc_arguments->{'_'}{live_update} =~ /\A\d+\z/
        && $rc_arguments->{'_'}{live_update} > 0) {
        my $now = time;
        my $last_mod = (stat $rc_filename)[9];
        {
            no warnings 'redefine';
            *_initialize = sub {
                if (time - $now > $rc_arguments->{'_'}{live_update}) {
                    my $new_last_mod = (stat $rc_filename)[9];
                    if (defined $new_last_mod && $new_last_mod > $last_mod) {
                        $now = time;
                        $last_mod = $new_last_mod;
                        $rc_arguments = Data::Printer::Config::load_rc_file($rc_filename);
                        if (!exists $rc_arguments->{'_'}{live_update} || !$rc_arguments->{'_'}{live_update}) {
                            *_initialize = sub {};
                        }
                    }
                }
            };
        }
    }
}

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

    _initialize();

    my $caller = caller;
    my $args_to_use = _fetch_args_with($caller, \%properties);
    return '' if $args_to_use->{quiet};
    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);
    return if $args_to_use->{quiet};
    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);
    return if $args_to_use->{quiet};
    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__