File Coverage

blib/lib/YATT/Lite/XHF/Dumper.pm

Criterion	Covered	Total	%
statement	51	56	91.0
branch	17	18	94.4
condition	15	18	83.3
subroutine	13	13	100.0
pod	0	5	0.0
total	96	110	87.2

package YATT::Lite::XHF::Dumper;
use strict;
use warnings qw(FATAL all NONFATAL misc);
our $VERSION = "0.02";

use Exporter qw(import);
our @EXPORT_OK = qw(dump_xhf);
our @EXPORT = @EXPORT_OK;

use 5.010;
use Carp;

use YATT::Lite::XHF qw($cc_name);

sub dump_xhf {
  shift;
  _dump_pairs(@_);
}

sub _dump_pairs {
  my @buffer;
  while (@_) {
    if (@_ == 1 or not defined $_[0] or ref $_[0]) {
      push @buffer, _dump_value(shift, '-');
    } elsif ($_[0] =~ m{^$cc_name+$}) {
      push @buffer, shift() . _dump_value(shift, ':');
    } else {
      # ('', undef) => "-\n= #null"
      push @buffer, '-' . escape(shift), _dump_value(shift, '-');
    }
  }
  join "\n", @buffer;
}

sub _dump_value {
    # value part.
  unless (defined $_[0]) {
    "= #null";
  } elsif (not ref $_[0]) {
    $_[1] . escape(shift);
  } elsif (ref $_[0] eq 'ARRAY') {
    dump_array(shift);
  } elsif (ref $_[0] eq 'HASH') {
    dump_hash(shift);
  } else {
    croak "Can't dump ref(@{[ref $_[0]]}) as XHF: $_[0]";
  }
}

sub escape {
  my ($str) = @_;
  my $sep = do {
    if ($str =~ s/\n$// or $str =~ /^\s+|\s+$/s) {
      "\n "
    } else {
      " "
    }
  };
  $str =~ s/\n/\n /g;
  $sep . $str;
}

sub dump_array {
  my ($item) = @_;
  "[\n" . join("\n", do {
    if (@$item and @$item % 2 == 0 and looks_like_hash($item)) {
      _dump_pairs(@$item);
    } else {
      map {_dump_value($_, '-')} @$item
    }
  }) . "\n]";
}

sub looks_like_hash {
  my ($item) = @_;
  for (my $i = 0; $i < @$item; $i += 2) {
    return 0 if ref($item->[$i]) or $item->[$i] !~ m{^$cc_name+$};
  }
  return 1;
}

sub dump_hash {
  my ($item) = @_;
  "{\n" . _dump_pairs(map {$_, $item->{$_}} sort keys %$item) . "\n}";
}

__END__