File Coverage

blib/lib/Data/Dump/Partial.pm

Criterion	Covered	Total	%
statement	100	101	99.0
branch	52	54	96.3
condition	47	50	94.0
subroutine	8	9	88.8
pod	2	2	100.0
total	209	216	96.7

package Data::Dump::Partial;

use 5.010001;
use strict;
use warnings;
use experimental 'smartmatch';
use Data::Dump::Filtered;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(dump_partial dumpp);

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2024-01-02'; # DATE
our $DIST = 'Data-Dump-Partial'; # DIST
our $VERSION = '0.070'; # VERSION

sub _dmp { Data::Dump::Filtered::dump_filtered(@_, undef) }

sub dump_partial {
    my @data = @_;
    die 'Usage: dump_partial(@data, \%opts)'
        if @data > 1 && ref($data[-1]) ne 'HASH';
    my $opts = (@data > 1) ? {%{pop(@data)}} : {};

    $opts->{max_keys}      //=  5;
    $opts->{max_elems}     //=  5;
    $opts->{max_len}       //= 32;
    $opts->{max_total_len} //= 80;

    $opts->{max_keys} = @{$opts->{precious_keys}} if $opts->{precious_keys} &&
        @{ $opts->{precious_keys} } > $opts->{max_keys};

    my $out;

    if ($opts->{_inner}) {
        #print "DEBUG: inner dump, data="._dmp(@data)."\n";
        $out = Data::Dump::dump(@data);
    } else {
        #print "DEBUG: outer dump, data="._dmp(@data)."\n";
        my $filter = sub {
            my ($ctx, $oref) = @_;

            # to avoid deep recursion (dump_partial keeps modifying the hash due
            # to pair_filter or mask_keys_regex)
            my $skip_modify_outermost_hash;
            if ($opts->{_skip_modify_outermost_hash}) {
                #print "DEBUG: Will skip modify outermost hash\n";
                $skip_modify_outermost_hash++;
                $opts->{_skip_modify_outermost_hash}--;
            }

            if ($opts->{max_len} && $ctx->is_scalar && defined($$oref) &&
                    length($$oref) > $opts->{max_len}) {

                #print "DEBUG: truncating scalar\n";
                return { object => substr($$oref, 0, $opts->{max_len}-3)."..." };

            } elsif ($opts->{max_elems} && $ctx->is_array &&
                         @$oref > $opts->{max_elems}) {

                #print "DEBUG: truncating array\n";
                my @ary = @{$oref}[0..($opts->{max_elems}-1)];
                local $opts->{_inner} = 1;
                local $opts->{max_total_len} = 0;
                my $out = dump_partial(\@ary, $opts);
                $out =~ s/(?:, )?]$/, ...]/;
                return { dump => $out };

            } elsif ($ctx->is_hash) {

                my %hash;
                my $modified;

                if ($opts->{pair_filter} && !$skip_modify_outermost_hash) {
                    for (sort keys %$oref) {
                        my @res = $opts->{pair_filter}->($_, $oref->{$_});
                        $modified = "pair_filter" unless @res == 2 &&
                            $res[0] eq $_ && "$res[1]" eq "$oref->{$_}";
                        while (my ($k, $v) = splice @res, 0, 2) {
                            $hash{$k} = $v;
                        }
                    }
                } else {
                    %hash = %$oref;
                }

                if ($opts->{mask_keys_regex} && !$skip_modify_outermost_hash) {
                    for (sort keys %hash) {
                        if (/$opts->{mask_keys_regex}/) {
                            $modified = "mask_keys_regex";
                            $hash{$_} = '***';
                        }
                    }
                }

                my $truncated;
                if ($opts->{max_keys} && keys(%$oref) > $opts->{max_keys}) {
                    my $mk = $opts->{max_keys};
                    {
                        if ($opts->{hide_keys}) {
                            for my $k (sort keys %hash) {
                                delete $hash{$k} if grep { $_ eq $k } @{$opts->{hide_keys}};
                            }
                        }
                        last if keys(%hash) <= $mk;
                        if ($opts->{worthless_keys}) {
                            for my $k (sort keys %hash) {
                                last if keys(%hash) <= $mk;
                                delete $hash{$k} if grep { $_ eq $k } @{$opts->{worthless_keys}};
                            }
                        }
                        last if keys(%hash) <= $mk;
                        for my $k (reverse sort keys %hash) {
                            delete $hash{$k} if !$opts->{precious_keys} ||
                                !(grep { $_ eq $k } @{$opts->{precious_keys}});
                            last if keys(%hash) <= $mk;
                        }
                    }
                    $modified = "truncate";
                    $truncated++;
                }

                if ($modified) {
                    #print "DEBUG: modified hash ($modified)\n";
                    local $opts->{_inner} = 1;
                    local $opts->{_skip_modify_outermost_hash} = 1;
                    local $opts->{max_total_len} = 0;
                    my $out = dump_partial(\%hash, $opts);
                    $out =~ s/(?:, )? }$/, ... }/ if $truncated;
                    return { dump => $out };
                }
            }

            if ($opts->{dd_filter}) {
                return $opts->{dd_filter}->($ctx, $oref);
            } else {
                return;
            }
        };
        $out = Data::Dump::Filtered::dump_filtered(@data, $filter);
    }

    for ($out) {
        s/^\s*#.*//mg; # comments
        s/^\s+//mg; # indents
        s/\n+/ /g; # newlines
    }

    if ($opts->{max_total_len} && length($out) > $opts->{max_total_len}) {
        $out = substr($out, 0, $opts->{max_total_len}-3) . "...";
    }

    print STDERR "$out\n" unless defined wantarray;
    $out;
}

sub dumpp { dump_partial(@_) }

1;
# ABSTRACT: Dump data structure compactly and potentially partially

__END__