File Coverage

blib/lib/YAML/Dump.pm
Criterion Covered Total %
statement 126 148 85.1
branch 65 80 81.2
condition 11 18 61.1
subroutine 16 16 100.0
pod 3 3 100.0
total 221 265 83.4


line stmt bran cond sub pod time code
1             package YAML::Dump; # adapted from YAML::Tiny 1.73
2 2     2   72548 use 5.010; # this is where I want to start from
  2         16  
3 2     2   10 use strict;
  2         5  
  2         68  
4             # use warnings; # disabled in modules
5             { our $VERSION = '1.81'; }
6              
7 2     2   11 use B;
  2         3  
  2         93  
8 2     2   11 use Scalar::Util qw< blessed refaddr >;
  2         3  
  2         98  
9 2     2   21 use Exporter qw< import >;
  2         3  
  2         112  
10              
11             our @EXPORT_OK = qw{ Dump INDENT };
12              
13 2     2   12 use constant INDENT => ' ';
  2         10  
  2         3925  
14              
15 19     19 1 15958 sub Dump { return YAML::Dump->new(@_)->_dump_string; }
16              
17 19     19 1 31 sub new { my $class = shift; bless [ @_ ], $class; }
  19         63  
18              
19             sub dumper_for_objects { # support for dumping booleans
20 15     15 1 22 my $self = shift;
21              
22             # try to look for booleans
23 15 100       29 if (my $line = $self->_tentative_dumper_for_boolean(@_)) {
24 8         65 return $line;
25             }
26              
27             # check derived class or monkey patching
28 7 50       26 if ($self->can('dumper_for_unknown')) {
29 7         19 my @retval = $self->dumper_for_unknown(@_);
30 4 100 66     124 return @retval unless (@retval == 1) && ref($retval[0]);
31 1         5 my (undef, $line, $indent, $seen) = @_;
32 1         2 my $type = ref $retval[0];
33 1 50       6 my @lines =
    50          
34             ($type eq 'ARRAY') ? $self->_dump_array($retval[0], $indent, $seen)
35             : ($type eq 'HASH') ? $self->_dump_hash($retval[0], $indent, $seen)
36             : die \"YAML::Dump does not support $type references";
37 1 50       8 if ($line =~ m{-\s*$}mxs) {
38 1         3 substr $lines[0], 0, length($line), $line;
39 1         6 return @lines;
40             }
41             else {
42 0         0 return $line, @lines;
43             }
44             }
45              
46             # last resort... complain loudly
47 0         0 my $type = ref $_[0];
48 0         0 die \"YAML::Dump does not support $type references";
49             }
50              
51             sub _tentative_dumper_for_boolean {
52 15     15   31 my ($self, $element, $line, $indent, $seen) = @_;
53              
54 15 100 66     72 if (blessed $element) {
    100 66        
55 9         15 state $boolean_candidates = [
56             'JSON::PP::Boolean',
57             'boolean',
58             'JSON::XS::Boolean',
59             'Types::Serialiser::Boolean', # should not be needed
60             'Mojo::JSON::_Bool', # only up to Mojolicious 6.21
61             ];
62 9         16 for my $boolean (@$boolean_candidates) {
63 29 100       113 next unless $element->isa($boolean);
64 4 100       90 return $line . ($element ? ' true' : ' false');
65             }
66             }
67             elsif ((ref($element) eq 'SCALAR') && defined($$element)
68             && (ref(my $bo = B::svref_2object($element)) eq 'B::IV'))
69             {
70 5         31 my $value = $bo->int_value;
71 5 100       15 return $line . ' false' if $value == 0;
72 4 100       14 return $line . ' true' if $value == 1;
73             }
74              
75 7         20 return;
76             }
77              
78             #####################################################################
79             # Constants
80              
81             # Printed form of the unprintable characters in the lowest range
82             # of ASCII characters, listed by ASCII ordinal position.
83             my @UNPRINTABLE = qw(
84             0 x01 x02 x03 x04 x05 x06 a
85             b t n v f r x0E x0F
86             x10 x11 x12 x13 x14 x15 x16 x17
87             x18 x19 x1A e x1C x1D x1E x1F
88             );
89              
90             # Printable characters for escapes
91             my %UNESCAPES = (
92             0 => "\x00", z => "\x00", N => "\x85",
93             a => "\x07", b => "\x08", t => "\x09",
94             n => "\x0a", v => "\x0b", f => "\x0c",
95             r => "\x0d", e => "\x1b", '\\' => '\\',
96             );
97              
98             # These 3 values have special meaning when unquoted and using the
99             # default YAML schema. They need quotes if they are strings.
100             my %QUOTE = map { $_ => 1 } qw{ null true false };
101              
102              
103             #####################################################################
104             # YAML::Tiny Implementation.
105             #
106             # These are the private methods that do all the work. They may change
107             # at any time, most probably as a result of changes in YAML::Tiny
108              
109             # Save an object to a string
110             sub _dump_string {
111 19     19   28 my $self = shift;
112 19 50 33     100 return '' unless ref $self && @$self;
113              
114             # Iterate over the documents
115 19         30 my $indent = 0;
116 19         29 my @lines = ();
117              
118 19         27 eval {
119 19         32 foreach my $cursor ( @$self ) {
120 19         36 push @lines, '---';
121              
122             # An empty document
123 19 100       82 if ( ! defined $cursor ) {
    100          
    100          
    100          
124             # Do nothing
125              
126             # A scalar document
127             } elsif ( ! ref $cursor ) {
128 3         33 $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
129              
130             # A list at the root
131             } elsif ( ref $cursor eq 'ARRAY' ) {
132 4 100       9 unless ( @$cursor ) {
133 1         2 $lines[-1] .= ' []';
134 1         3 next;
135             }
136 3         12 push @lines, $self->_dump_array( $cursor, $indent, {} );
137              
138             # A hash at the root
139             } elsif ( ref $cursor eq 'HASH' ) {
140 4 100       10 unless ( %$cursor ) {
141 1         2 $lines[-1] .= ' {}';
142 1         2 next;
143             }
144 3         8 push @lines, $self->_dump_hash( $cursor, $indent, {} );
145              
146             } else {
147 7         19 my @objs = $self->dumper_for_objects( $cursor, '', $indent, {} );
148 4 50       13 if (@objs == 1) {
149 4         14 $lines[-1] .= $objs[0];
150             }
151             else {
152 0         0 push @lines, @objs;
153             }
154             }
155             }
156             };
157 19 100       80 if ( ref $@ eq 'SCALAR' ) {
    50          
158 4         7 $self->_error(${$@});
  4         10  
159             } elsif ( $@ ) {
160 0         0 $self->_error($@);
161             }
162              
163 15         27 join '', map { "$_\n" } @lines;
  51         164  
164             }
165              
166             sub _has_internal_string_value {
167 34     34   50 my $value = shift;
168 34         78 my $b_obj = B::svref_2object(\$value); # for round trip problem
169 34         101 return $b_obj->FLAGS & B::SVf_POK();
170             }
171              
172             sub _dump_scalar {
173 34     34   49 my $string = $_[1];
174 34         45 my $is_key = $_[2];
175             # Check this before checking length or it winds up looking like a string!
176 34         50 my $has_string_flag = _has_internal_string_value($string);
177 34 50       65 return '~' unless defined $string;
178 34 50       59 return "''" unless length $string;
179 34 100       82 if (Scalar::Util::looks_like_number($string)) {
180             # keys and values that have been used as strings get quoted
181 15 100 66     42 if ( $is_key || $has_string_flag ) {
182 1         6 return qq['$string'];
183             }
184             else {
185 14         33 return $string;
186             }
187             }
188 19 50       46 if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
189 0         0 $string =~ s/\\/\\\\/g;
190 0         0 $string =~ s/"/\\"/g;
191 0         0 $string =~ s/\n/\\n/g;
192 0         0 $string =~ s/[\x85]/\\N/g;
193 0         0 $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
194 0         0 $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
  0         0  
195 0         0 return qq|"$string"|;
196             }
197 19 100 66     148 if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
198             $QUOTE{$string}
199             ) {
200 1         4 return "'$string'";
201             }
202 18         51 return $string;
203             }
204              
205             sub _dump_array {
206 7     7   14 my ($self, $array, $indent, $seen) = @_;
207 7 50       30 if ( $seen->{refaddr($array)}++ ) {
208 0         0 die \"YAML::Dump does not support circular references";
209             }
210 7         10 my @lines = ();
211 7         13 foreach my $el ( @$array ) {
212 25         42 my $line = (INDENT x $indent) . '-';
213 25         37 my $type = ref $el;
214 25 100       51 if ( ! $type ) {
    100          
    100          
215 15         25 $line .= ' ' . $self->_dump_scalar( $el );
216 15         37 push @lines, $line;
217              
218             } elsif ( $type eq 'ARRAY' ) {
219 2 50       5 if ( @$el ) {
220 2         3 push @lines, $line;
221 2         5 push @lines, $self->_dump_array( $el, $indent + 1, $seen );
222             } else {
223 0         0 $line .= ' []';
224 0         0 push @lines, $line;
225             }
226              
227             } elsif ( $type eq 'HASH' ) {
228 2 50       6 if ( keys %$el ) {
229 2         5 my $first = @lines;
230 2         7 push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
231 2         8 substr $lines[$first], 0, length($line), $line;
232             } else {
233 0         0 $line .= ' {}';
234 0         0 push @lines, $line;
235             }
236              
237             } else {
238 6         13 push @lines, $self->dumper_for_objects($el, $line, $indent + 1, $seen);
239             }
240             }
241 7         17 $seen->{refaddr($array)}--;
242              
243 7         36 @lines;
244             }
245              
246             sub _dump_hash {
247 8     8   18 my ($self, $hash, $indent, $seen) = @_;
248 8 100       34 if ( $seen->{refaddr($hash)}++ ) {
249 1         6 die \"YAML::Dump does not support circular references";
250             }
251 7         11 my @lines = ();
252 7         24 foreach my $name ( sort keys %$hash ) {
253 11         18 my $el = $hash->{$name};
254 11         24 my $line = (INDENT x $indent) . $self->_dump_scalar($name, 1) . ":";
255 11         50 my $type = ref $el;
256 11 100       30 if ( ! $type ) {
    100          
    100          
257 5         21 $line .= ' ' . $self->_dump_scalar( $el );
258 5         13 push @lines, $line;
259              
260             } elsif ( $type eq 'ARRAY' ) {
261 2 50       6 if ( @$el ) {
262 2         3 push @lines, $line;
263 2         8 push @lines, $self->_dump_array( $el, $indent + 1, $seen );
264             } else {
265 0         0 $line .= ' []';
266 0         0 push @lines, $line;
267             }
268              
269             } elsif ( $type eq 'HASH' ) {
270 2 50       6 if ( keys %$el ) {
271 2         4 push @lines, $line;
272 2         17 push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
273             } else {
274 0         0 $line .= ' {}';
275 0         0 push @lines, $line;
276             }
277              
278             } else {
279 2         9 push @lines, $self->dumper_for_objects($el, $line, $indent + 1, $seen);
280             }
281             }
282 5         14 $seen->{refaddr($hash)}--;
283              
284 5         19 @lines;
285             }
286              
287             sub _error {
288 4     4   8 my $errstr = $_[1];
289 4         11 $errstr =~ s/ at \S+ line \d+.*//;
290 4         21 require Carp;
291 4         41 Carp::croak( $errstr );
292             }
293              
294             1;