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


line stmt bran cond sub pod time code
1             package YATT::Lite::XHF::Dumper;
2 4     4   1195 use strict;
  4         11  
  4         156  
3 4     4   26 use warnings qw(FATAL all NONFATAL misc);
  4         10  
  4         267  
4             our $VERSION = "0.02";
5              
6 4     4   28 use Exporter qw(import);
  4         10  
  4         268  
7             our @EXPORT_OK = qw(dump_xhf);
8             our @EXPORT = @EXPORT_OK;
9              
10 4     4   103 use 5.010;
  4         24  
11 4     4   29 use Carp;
  4         11  
  4         352  
12              
13 4     4   30 use YATT::Lite::XHF qw($cc_name);
  4         10  
  4         2906  
14              
15             sub dump_xhf {
16 17     17 0 16884 shift;
17 17         62 _dump_pairs(@_);
18             }
19              
20             sub _dump_pairs {
21 23     23   41 my @buffer;
22 23         74 while (@_) {
23 38 100 100     364 if (@_ == 1 or not defined $_[0] or ref $_[0]) {
    100 100        
24 12         37 push @buffer, _dump_value(shift, '-');
25             } elsif ($_[0] =~ m{^$cc_name+$}) {
26 22         86 push @buffer, shift() . _dump_value(shift, ':');
27             } else {
28             # ('', undef) => "-\n= #null"
29 4         17 push @buffer, '-' . escape(shift), _dump_value(shift, '-');
30             }
31             }
32 23         170 join "\n", @buffer;
33             }
34              
35             sub _dump_value {
36             # value part.
37 52 50   52   153 unless (defined $_[0]) {
    100          
    100          
    100          
38 9         43 "= #null";
39 0         0 } elsif (not ref $_[0]) {
40 32         72 $_[1] . escape(shift);
41 0         0 } elsif (ref $_[0] eq 'ARRAY') {
42 9         19 dump_array(shift);
43 0         0 } elsif (ref $_[0] eq 'HASH') {
44 2         7 dump_hash(shift);
45             } else {
46 0         0 croak "Can't dump ref(@{[ref $_[0]]}) as XHF: $_[0]";
  0         0  
47             }
48             }
49              
50             sub escape {
51 36     36 0 78 my ($str) = @_;
52 36         55 my $sep = do {
53 36 100 66     197 if ($str =~ s/\n$// or $str =~ /^\s+|\s+$/s) {
54 3         9 "\n "
55             } else {
56 33         74 " "
57             }
58             };
59 36         79 $str =~ s/\n/\n /g;
60 36         162 $sep . $str;
61             }
62              
63             sub dump_array {
64 9     9 0 17 my ($item) = @_;
65 9         13 "[\n" . join("\n", do {
66 9 100 66     86 if (@$item and @$item % 2 == 0 and looks_like_hash($item)) {
      100        
67 4         11 _dump_pairs(@$item);
68             } else {
69 5         13 map {_dump_value($_, '-')} @$item
  14         27  
70             }
71             }) . "\n]";
72             }
73              
74             sub looks_like_hash {
75 5     5 0 11 my ($item) = @_;
76 5         16 for (my $i = 0; $i < @$item; $i += 2) {
77 9 100 66     98 return 0 if ref($item->[$i]) or $item->[$i] !~ m{^$cc_name+$};
78             }
79 4         13 return 1;
80             }
81              
82             sub dump_hash {
83 2     2 0 25 my ($item) = @_;
84 2         14 "{\n" . _dump_pairs(map {$_, $item->{$_}} sort keys %$item) . "\n}";
  5         16  
85             }
86              
87             __END__