File Coverage

blib/lib/Data/Dumper/Compact.pm

Criterion	Covered	Total	%
statement	198	249	79.5
branch	82	136	60.2
condition	16	39	41.0
subroutine	38	43	88.3
pod	6	6	100.0
total	340	473	71.8

package Data::Dumper::Compact;

use List::Util qw(sum);
use Scalar::Util qw(blessed reftype);
use Data::Dumper ();
use Mu::Tiny;

our $VERSION = '0.006000';
$VERSION =~ tr/_//d;

sub import {
  my ($class, $ddc, $opts) = @_;
  return unless defined($ddc);
  die "Don't know how to export '$ddc'" unless ($ddc||'') =~ /^[jd]dc$/;
  my $targ = caller;
  my $cb = $class->new($opts||{})->dump_cb;
  no strict 'refs';
  *{"${targ}::${ddc}"} = $cb;
}

lazy max_width => sub { 78 };

lazy width => sub { shift->max_width };

lazy indent_width => sub { length($_[0]->indent_by) };

sub _next_width { $_[0]->width - $_[0]->indent_width }

lazy indent_by => sub { '  ' };

lazy transforms => sub { [] };

sub add_transform { push(@{$_[0]->transforms}, $_[1]); $_[0] }

sub _indent {
  my ($self, $string) = @_;
  my $ib = $self->indent_by;
  $string =~ s/^/$ib/msg;
  $string;
}

lazy dumper => sub {
  my ($self) = @_;
  my $dd = Data::Dumper->new([]);
  $dd->Trailingcomma(1) if $dd->can('Trailingcomma');
  $dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
  my $indent_width = $self->indent_width;
  # feed the indent width down into B::Deparse - not using tabs because
  # it has no way to tell it how wide a tab is that I could find
  my $dp_new = do {
    require B::Deparse;
    my $orig = \&B::Deparse::new;
    sub { my ($self, @args) = @_; $self->$orig('-si'.$indent_width, @args) }
  };
  sub {
    no warnings 'redefine';
    local *B::Deparse::new = $dp_new;
    $dd->Values([ $_[0] ])->Dump
  },
};

sub _dumper { $_[0]->dumper->($_[1]) }

sub _optify {
  my ($self, $opts, $method, @args) = @_;
  # if we're an object, localize anything provided in the options,
  # and also blow away the dependent attributes if indent_by is changed
  ref($self) and $opts
    and (local @{$self}{keys %$opts} = values %$opts, 1)
    and $opts->{indent_by}
    and delete @{$self}{grep !$opts->{$_}, qw(indent_width dumper)};
  ref($self) or $self = $self->new($opts||{});
  $self->$method(@args);
}

sub dump {
  my ($self, $data, $opts) = @_;
  $self->_optify($opts, sub {
    my ($self) = @_;
    $self->format($self->transform($self->transforms, $self->expand($data)));
  });
}

sub dump_cb {
  my ($self) = @_;
  return sub { $self->dump(@_) };
}

sub expand {
  my ($self, $data, $p) = @_;
  local $self->{expand_seen} = {} unless $self->{expand_seen};
  my $this_path = [
     ($self->{expand_path} ? @{$self->{expand_path}} : ()),
     (defined($p) ? ($p) : ())
  ];
  if (ref($data)) {
    if (my $seen_path = $self->{expand_seen}{$data}) {
      return [ ref => $seen_path ];
    } else {
      $self->{expand_seen}{$data} = $this_path;
    }
  }
  local $self->{expand_path} = $this_path;
  if (ref($data) eq 'HASH') {
    return [ hash => [
      [ sort keys %$data ],
      { map +($_ => $self->expand($data->{$_}, [ key => $_ ])), sort keys %$data }
    ] ];
  } elsif (ref($data) eq 'ARRAY') {
    my $idx = 0;
    return [ array => [ map $self->expand($_, [ idx => $idx++ ]), @$data ] ];
  } elsif (blessed($data) and my $ret = $self->_expand_blessed($data)) {
    return $ret;
  }
  (my $thing = $self->_dumper($data)) =~ s/\n\Z//;

  # -foo and friends automatically become 'key' type, all else stays 'string'
  if (my ($string) = $thing =~ /^"(.*)"$/) {
    return [ ($string =~ /^-[a-zA-Z]\w*$/ ? 'key' : 'string') => $string ];
  }
  return [ thing => $thing ];
}

sub _expand_blessed {
  my ($self, $blessed) = @_;
  return unless grep { $_ eq 'ARRAY' or $_ eq 'HASH' } reftype($blessed);
  my $cursed = reftype($blessed) eq 'ARRAY' ? [ @$blessed ] : { %$blessed };
  return [ blessed => [ $self->expand($cursed), blessed($blessed) ] ];
}

sub transform {
  my ($self, $tfspec, $exp) = @_;
  return $exp unless $tfspec;
  # This is redundant from ->dump but consistent for direct user calls
  local $self->{transforms} = $tfspec;
  $self->_transform($exp, []);
}

sub _transform {
  my ($self, $exp, $path) = @_;
  my ($type, $payload) = @$exp;
  if ($type eq 'hash') {
    my %h = %{$payload->[1]};
    $payload = [
      $payload->[0],
      { map +(
          $_ => $self->_transform($h{$_}, [ @$path, $_ ])
        ), sort keys %h
      },
    ];
  } elsif ($type eq 'array') {
    my @a = @$payload;
    $payload = [ map $self->_transform($a[$_], [ @$path, $_ ]), 0..$#a ];
  }
  TF: foreach my $this_tf (@{$self->transforms}) {
    my $tf = $this_tf;
    my $last_tf = 0;
    while ($tf != $last_tf) {
      $last_tf = $tf;
      if (ref($tf) eq 'ARRAY') {
        my @match = @$tf;
        $tf = pop @match;
        next TF if @match > @$path; # not deep enough
        MATCH: foreach my $idx (0..$#match) {
          next MATCH unless defined(my $m = $match[$idx]);
          my $rpv = $path->[$idx-@match];
          if (!ref($m)) {
            next TF unless $rpv eq $m;
          } elsif (ref($m) eq 'Regexp') {
            next TF unless $rpv =~ $m;
          } elsif (ref($m) eq 'CODE') {
            local $_ = $rpv;
            next TF unless $m->($rpv);
          } else {
            die "Unknown path match type for $m";
          }
        }
      } elsif (ref($tf) eq 'HASH') {
        next TF unless $tf = $tf->{$type}||$tf->{_};
      }
    }
    ($type, $payload) = @{
      $self->$tf($type, $payload, $path)
      || [ $type, $payload ]
    };
  }
  return [ $type, $payload ];
}

sub format {
  my ($self, $exp) = @_;
  return $self->_format($exp)."\n";
  # If we realise we've flat run out of horizontal space, we need to be able
  # to jump back up the call stack to the top and start again - hence the
  # presence of this label to jump to from _format - of course, if that
  # clause never gets hit then our first _format call returns and therefore
  # the label is never reached.
  VERTICAL:
  local $self->{vertical} = 1;
  return $self->_format($exp)."\n";
}

sub _format {
  my ($self, $exp) = @_;
  my ($type, $payload) = @$exp;
  if (!$self->{vertical} and $self->width <= 0) {
    # We've run out of horizontal space, engage 'vertical sprawl mode' and
    # restart from the top by jumping back up the current call stack to the
    # VERTICAL label in the top-level call to format.
    no warnings 'exiting';
    goto VERTICAL;
  }
  return $self->${\"_format_${type}"}($payload);
}

sub _format_list {
  my ($self, $payload) = @_;
  my @plain = grep !/\s/, map $_->[1], grep $_->[0] eq 'string', @$payload;
  if (@plain == @$payload) {
    my $try = 'qw('.join(' ', @plain).')';
    return $try if $self->{oneline} or length($try) <= $self->width;
  }
  return $self->_format_arraylike('(', ')', $payload);
}

sub _format_array {
  my ($self, $payload) = @_;
  $self->_format_arraylike('[', ']', $payload);
}

sub _format_el {
  my ($self, $el) = @_;
  return $el->[1].' =>' if $el->[0] eq 'key';
  return $self->_format($el).',';
}

sub _format_arraylike {
  my ($self, $l, $r, $payload) = @_;
  if ($self->{vertical}) {
    return join("\n", $l,
      (map $self->_indent($self->_format($_).','), @$payload),
    $r);
  }
  return $l.$r unless my @pl = @$payload;
  my $last_pl = pop @pl;
  # We don't want 'foo =>' at the end of the array, so for the last
  # entry use plain _format which will render key-as-string, and don't
  # add a comma yet because we don't want a trailing comma on a single
  # line render
  my @oneline = do {
    local $self->{oneline} = 1;
    ((map $self->_format_el($_), @pl), $self->_format($last_pl));
  };
  if (!grep /\n/, @oneline) {
    my $try = join(' ', $l, @oneline, $r);
    return $try if $self->{oneline} or length $try <= $self->width;
  }
  local $self->{width} = $self->_next_width;
  if (@$payload == 1) {
    # single entry, re-format the payload without oneline set
    return $self->_format_single($l, $r, $self->_format($payload->[0]));
  }
  if (@$payload == 2 and $payload->[0][0] eq 'key') {
    my $s = (my $k = $self->_format_el($payload->[0]))
            .' '.$self->_format(my $p = $payload->[1]);
    return $self->_format_single($l, $r, do {
      $s =~ /\A(.{0,${\$self->width}})(?:\n|\Z)/
        ? $s
        : $k."\n".do {
            local $self->{width} = $self->_next_width;
            $self->_indent($self->_format($p));
          }
    });
  }
  my @lines;
  my @bits;
  $oneline[-1] .= ','; # going into multiline mode, *now* we add the comma
  foreach my $idx (0..$#$payload) {
    my $spare = $self->width - sum((scalar @bits)+1, map length($_), @bits);
    my $f = $oneline[$idx];
    if ($f !~ /\n/) {
      # single line entry, add to the bits for the current line if it'll fit
      # otherwise collapse bits into a line and start afresh with this entry
      if (length($f) <= $spare) {
        push @bits, $f;
        next;
      }
      if (length($f) <= $self->width) {
        push(@lines, join(' ', @bits));
        @bits = ($f);
        next;
      }
    }
    # If it didn't format as a single line, re-format to avoid confusion
    $f = $self->_format_el($payload->[$idx]);

    # if we can fit the first line in the available remaining space in the
    # current line, do that
    if ($spare > 0 and $f =~ s/^(.{0,${spare}})\n//sm) {
      push @bits, $1;
    }
    push(@lines, join(' ', @bits)) if @bits;
    @bits = ();
    # if the last line is less than our available width, turn that into
    # an entry in a new line
    if ($f =~ s/(?:\A|\n)(.{0,${\$self->width}})\Z//sm) {
      push @bits, $1;
    }
    # stuff whatever's left from the middle into the line array
    push(@lines, $f) if length($f);
  }
  push @lines, join(' ', @bits) if @bits;
  return join("\n", $l, (map $self->_indent($_), @lines), $r);
}

sub _format_hashkey {
  my ($self, $key) = @_;
  ($key =~ /^-?[a-zA-Z_]\w*$/
    ? $key
    # stick a space on the front to force dumping of e.g. 123, then strip it
    : do {
       s/^" //, s/"\n\Z// for my $s = $self->_dumper(" $key");
       $self->_format_string($s)
    }
  ).' =>';
}

sub _format_hash {
  my ($self, $payload) = @_;
  my ($keys, $hash) = @$payload;
  return '{}' unless @$keys;
  @$keys = sort @$keys;
  my %k = (map +(
    $_ => $self->_format_hashkey($_)), @$keys
  );
  if ($self->{vertical}) {
    return join("\n", '{',
      (map $self->_indent($k{$_}.' '.$self->_format($hash->{$_}).','), @$keys),
    '}');
  }
  my $oneline = do {
    local $self->{oneline} = 1;
    join(' ', '{', join(', ',
      map $k{$_}.' '.$self->_format($hash->{$_}), @$keys
    ), '}');
  };
  return $oneline if $self->{oneline};
  return $oneline if $oneline !~ /\n/ and length($oneline) <= $self->width;
  my $width = local $self->{width} = $self->_next_width;
  my @f = map {
    my $s = $k{$_}.' '.$self->_format(my $p = $hash->{$_});
    $s =~ /\A(.{0,${width}})(?:\n|\Z)/
      ? $s
      : $k{$_}."\n".do {
          local $self->{width} = $self->_next_width;
          $self->_indent($self->_format($p));
        }
  } @$keys;
  local $self->{width} = $self->_next_width;
  if (@f == 1) {
    return $self->_format_single('{', '}', $f[0]);
  }
  return join("\n",
    '{',
    (map $self->_indent($_).',', @f),
    '}',
  );
}

sub _format_key { shift->_format_string(@_) }

sub _format_string {
  my ($self, $str) = @_;
  my $q = $str =~ /[\\']/ ? q{"} : q{'};
  my $w = $self->{vertical} ? 20 : $self->_next_width;
  return $q.$str.$q if length($str) <= $w;
  $w--;
  my @f;
  while (length(my $chunk = substr($str, 0, $w, ''))) {
    push @f, $q.$chunk.$q;
  }
  return join("\n.", @f);
}

sub _format_thing { $_[1] }

sub _format_single {
  my ($self, $l, $r, $raw) = @_;
  my ($first, @lines) = split /\n/, $raw;
  return join("\n", $l, $self->_indent($first), $r) unless @lines;
  (my $pad = $self->indent_by) =~ s/^ //;
  my $last = $lines[-1] =~ /^[\}\]\)]/ ? (pop @lines).$pad: '';
  local $self->{width} = $self->_next_width;
  return join("\n",
    $l.($l eq '{' ? ' ' : $pad).$first,
    (map $self->_indent($_), @lines),
    $last.$r
  );
}

sub _format_blessed {
  my ($self, $payload) = @_;
  my ($content, $class) = @$payload;
  return 'bless( '.$self->_format($content).qq{, "${class}"}.' )';
}

sub _format_ref {
  my ($self, $payload) = @_;
  return '$_->'.join('',
    map {
      if ($_->[0] eq 'key') {
        my $quoted = quotemeta($_->[1]);
        if ($_->[1] eq $quoted) {
          '{'.$quoted.'}'
        } else {
          '{"'.$quoted.'"}'
        }
      } elsif ($_->[0] eq 'idx') {
        '['.$_->[1].']'
      } else {
        die "Invalid ref element type ".$_->[0];
      }
    } @$payload
  );
}

1;
__END__