ActionBar: oe Prototyp
[kivitendo-erp.git] / modules / override / YAML / Dumper.pm
1 package YAML::Dumper;
2
3 use YAML::Mo;
4 extends 'YAML::Dumper::Base';
5
6 use YAML::Dumper::Base;
7 use YAML::Node;
8 use YAML::Types;
9 use Scalar::Util qw();
10
11 # Context constants
12 use constant KEY       => 3;
13 use constant BLESSED   => 4;
14 use constant FROMARRAY => 5;
15 use constant VALUE     => "\x07YAML\x07VALUE\x07";
16
17 # Common YAML character sets
18 my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
19 my $LIT_CHAR    = '|';
20
21 #==============================================================================
22 # OO version of Dump. YAML->new->dump($foo);
23 sub dump {
24     my $self = shift;
25     $self->stream('');
26     $self->document(0);
27     for my $document (@_) {
28         $self->{document}++;
29         $self->transferred({});
30         $self->id_refcnt({});
31         $self->id_anchor({});
32         $self->anchor(1);
33         $self->level(0);
34         $self->offset->[0] = 0 - $self->indent_width;
35         $self->_prewalk($document);
36         $self->_emit_header($document);
37         $self->_emit_node($document);
38     }
39     return $self->stream;
40 }
41
42 # Every YAML document in the stream must begin with a YAML header, unless
43 # there is only a single document and the user requests "no header".
44 sub _emit_header {
45     my $self = shift;
46     my ($node) = @_;
47     if (not $self->use_header and
48         $self->document == 1
49        ) {
50         $self->die('YAML_DUMP_ERR_NO_HEADER')
51           unless ref($node) =~ /^(HASH|ARRAY)$/;
52         $self->die('YAML_DUMP_ERR_NO_HEADER')
53           if ref($node) eq 'HASH' and keys(%$node) == 0;
54         $self->die('YAML_DUMP_ERR_NO_HEADER')
55           if ref($node) eq 'ARRAY' and @$node == 0;
56         # XXX Also croak if aliased, blessed, or ynode
57         $self->headless(1);
58         return;
59     }
60     $self->{stream} .= '---';
61 # XXX Consider switching to 1.1 style
62     if ($self->use_version) {
63 #         $self->{stream} .= " #YAML:1.0";
64     }
65 }
66
67 # Walk the tree to be dumped and keep track of its reference counts.
68 # This function is where the Dumper does all its work. All type
69 # transfers happen here.
70 sub _prewalk {
71     my $self = shift;
72     my $stringify = $self->stringify;
73     my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
74
75     # Handle typeglobs
76     if ($type eq 'GLOB') {
77         $self->transferred->{$node_id} =
78           YAML::Type::glob->yaml_dump($_[0]);
79         $self->_prewalk($self->transferred->{$node_id});
80         return;
81     }
82
83     # Handle regexps
84     if (ref($_[0]) eq 'Regexp') {
85         return;
86     }
87
88     # Handle Purity for scalars.
89     # XXX can't find a use case yet. Might be YAGNI.
90     if (not ref $_[0]) {
91         $self->{id_refcnt}{$node_id}++ if $self->purity;
92         return;
93     }
94
95     # Make a copy of original
96     my $value = $_[0];
97     ($class, $type, $node_id) = $self->node_info($value, $stringify);
98
99     # Must be a stringified object.
100     return if (ref($value) and not $type);
101
102     # Look for things already transferred.
103     if ($self->transferred->{$node_id}) {
104         (undef, undef, $node_id) = (ref $self->transferred->{$node_id})
105           ? $self->node_info($self->transferred->{$node_id}, $stringify)
106           : $self->node_info(\ $self->transferred->{$node_id}, $stringify);
107         $self->{id_refcnt}{$node_id}++;
108         return;
109     }
110
111     # Handle code refs
112     if ($type eq 'CODE') {
113         $self->transferred->{$node_id} = 'placeholder';
114         YAML::Type::code->yaml_dump(
115             $self->dump_code,
116             $_[0],
117             $self->transferred->{$node_id}
118         );
119         ($class, $type, $node_id) =
120           $self->node_info(\ $self->transferred->{$node_id}, $stringify);
121         $self->{id_refcnt}{$node_id}++;
122         return;
123     }
124
125     # Handle blessed things
126     if (defined $class) {
127         if ($value->can('yaml_dump')) {
128             $value = $value->yaml_dump;
129         }
130         elsif ($type eq 'SCALAR') {
131             $self->transferred->{$node_id} = 'placeholder';
132             YAML::Type::blessed->yaml_dump
133               ($_[0], $self->transferred->{$node_id});
134             ($class, $type, $node_id) =
135               $self->node_info(\ $self->transferred->{$node_id}, $stringify);
136             $self->{id_refcnt}{$node_id}++;
137             return;
138         }
139         else {
140             $value = YAML::Type::blessed->yaml_dump($value);
141         }
142         $self->transferred->{$node_id} = $value;
143         (undef, $type, $node_id) = $self->node_info($value, $stringify);
144     }
145
146     # Handle YAML Blessed things
147     require YAML;
148     if (defined YAML->global_object()->{blessed_map}{$node_id}) {
149         $value = YAML->global_object()->{blessed_map}{$node_id};
150         $self->transferred->{$node_id} = $value;
151         ($class, $type, $node_id) = $self->node_info($value, $stringify);
152         $self->_prewalk($value);
153         return;
154     }
155
156     # Handle hard refs
157     if ($type eq 'REF' or $type eq 'SCALAR') {
158         $value = YAML::Type::ref->yaml_dump($value);
159         $self->transferred->{$node_id} = $value;
160         (undef, $type, $node_id) = $self->node_info($value, $stringify);
161     }
162
163     # Handle ref-to-glob's
164     elsif ($type eq 'GLOB') {
165         my $ref_ynode = $self->transferred->{$node_id} =
166           YAML::Type::ref->yaml_dump($value);
167
168         my $glob_ynode = $ref_ynode->{&VALUE} =
169           YAML::Type::glob->yaml_dump($$value);
170
171         (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify);
172         $self->transferred->{$node_id} = $glob_ynode;
173         $self->_prewalk($glob_ynode);
174         return;
175     }
176
177     # Increment ref count for node
178     return if ++($self->{id_refcnt}{$node_id}) > 1;
179
180     # Keep on walking
181     if ($type eq 'HASH') {
182         $self->_prewalk($value->{$_})
183             for keys %{$value};
184         return;
185     }
186     elsif ($type eq 'ARRAY') {
187         $self->_prewalk($_)
188             for @{$value};
189         return;
190     }
191
192     # Unknown type. Need to know about it.
193     $self->warn(<<"...");
194 YAML::Dumper can't handle dumping this type of data.
195 Please report this to the author.
196
197 id:    $node_id
198 type:  $type
199 class: $class
200 value: $value
201
202 ...
203
204     return;
205 }
206
207 # Every data element and sub data element is a node.
208 # Everything emitted goes through this function.
209 sub _emit_node {
210     my $self = shift;
211     my ($type, $node_id);
212     my $ref = ref($_[0]);
213     if ($ref) {
214         if ($ref eq 'Regexp') {
215             $self->_emit(' !!perl/regexp');
216             $self->_emit_str("$_[0]");
217             return;
218         }
219         (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify);
220     }
221     else {
222         $type = $ref || 'SCALAR';
223         (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify);
224     }
225
226     my ($ynode, $tag) = ('') x 2;
227     my ($value, $context) = (@_, 0);
228
229     if (defined $self->transferred->{$node_id}) {
230         $value = $self->transferred->{$node_id};
231         $ynode = ynode($value);
232         if (ref $value) {
233             $tag = defined $ynode ? $ynode->tag->short : '';
234             (undef, $type, $node_id) =
235               $self->node_info($value, $self->stringify);
236         }
237         else {
238             $ynode = ynode($self->transferred->{$node_id});
239             $tag = defined $ynode ? $ynode->tag->short : '';
240             $type = 'SCALAR';
241             (undef, undef, $node_id) =
242               $self->node_info(
243                   \ $self->transferred->{$node_id},
244                   $self->stringify
245               );
246         }
247     }
248     elsif ($ynode = ynode($value)) {
249         $tag = $ynode->tag->short;
250     }
251
252     if ($self->use_aliases) {
253         $self->{id_refcnt}{$node_id} ||= 0;
254         if ($self->{id_refcnt}{$node_id} > 1) {
255             if (defined $self->{id_anchor}{$node_id}) {
256                 $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n";
257                 return;
258             }
259             my $anchor = $self->anchor_prefix . $self->{anchor}++;
260             $self->{stream} .= ' &' . $anchor;
261             $self->{id_anchor}{$node_id} = $anchor;
262         }
263     }
264
265     return $self->_emit_str("$value")   # Stringified object
266       if ref($value) and not $type;
267     return $self->_emit_scalar($value, $tag)
268       if $type eq 'SCALAR' and $tag;
269     return $self->_emit_str($value)
270       if $type eq 'SCALAR';
271     return $self->_emit_mapping($value, $tag, $node_id, $context)
272       if $type eq 'HASH';
273     return $self->_emit_sequence($value, $tag)
274       if $type eq 'ARRAY';
275     $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type);
276     return $self->_emit_str("$value");
277 }
278
279 # A YAML mapping is akin to a Perl hash.
280 sub _emit_mapping {
281     my $self = shift;
282     my ($value, $tag, $node_id, $context) = @_;
283     $self->{stream} .= " !$tag" if $tag;
284
285     # Sometimes 'keys' fails. Like on a bad tie implementation.
286     my $empty_hash = not(eval {keys %$value});
287     $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@;
288     return ($self->{stream} .= " {}\n") if $empty_hash;
289
290     # If CompressSeries is on (default) and legal is this context, then
291     # use it and make the indent level be 2 for this node.
292     if ($context == FROMARRAY and
293         $self->compress_series and
294         not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash)
295        ) {
296         $self->{stream} .= ' ';
297         $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2;
298     }
299     else {
300         $context = 0;
301         $self->{stream} .= "\n"
302           unless $self->headless && not($self->headless(0));
303         $self->offset->[$self->level+1] =
304           $self->offset->[$self->level] + $self->indent_width;
305     }
306
307     $self->{level}++;
308     my @keys;
309     if ($self->sort_keys == 1) {
310         if (ynode($value)) {
311             @keys = keys %$value;
312         }
313         else {
314             @keys = sort keys %$value;
315         }
316     }
317     elsif ($self->sort_keys == 2) {
318         @keys = sort keys %$value;
319     }
320     # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
321     elsif (ref($self->sort_keys) eq 'ARRAY') {
322         my $i = 1;
323         my %order = map { ($_, $i++) } @{$self->sort_keys};
324         @keys = sort {
325             (defined $order{$a} and defined $order{$b})
326               ? ($order{$a} <=> $order{$b})
327               : ($a cmp $b);
328         } keys %$value;
329     }
330     else {
331         @keys = keys %$value;
332     }
333     # Force the YAML::VALUE ('=') key to sort last.
334     if (exists $value->{&VALUE}) {
335         for (my $i = 0; $i < @keys; $i++) {
336             if ($keys[$i] eq &VALUE) {
337                 splice(@keys, $i, 1);
338                 push @keys, &VALUE;
339                 last;
340             }
341         }
342     }
343
344     for my $key (@keys) {
345         $self->_emit_key($key, $context);
346         $context = 0;
347         $self->{stream} .= ':';
348         $self->_emit_node($value->{$key});
349     }
350     $self->{level}--;
351 }
352
353 # A YAML series is akin to a Perl array.
354 sub _emit_sequence {
355     my $self = shift;
356     my ($value, $tag) = @_;
357     $self->{stream} .= " !$tag" if $tag;
358
359     return ($self->{stream} .= " []\n") if @$value == 0;
360
361     $self->{stream} .= "\n"
362       unless $self->headless && not($self->headless(0));
363
364     # XXX Really crufty feature. Better implemented by ynodes.
365     if ($self->inline_series and
366         @$value <= $self->inline_series and
367         not (scalar grep {ref or /\n/} @$value)
368        ) {
369         $self->{stream} =~ s/\n\Z/ /;
370         $self->{stream} .= '[';
371         for (my $i = 0; $i < @$value; $i++) {
372             $self->_emit_str($value->[$i], KEY);
373             last if $i == $#{$value};
374             $self->{stream} .= ', ';
375         }
376         $self->{stream} .= "]\n";
377         return;
378     }
379
380     $self->offset->[$self->level + 1] =
381       $self->offset->[$self->level] + $self->indent_width;
382     $self->{level}++;
383     for my $val (@$value) {
384         $self->{stream} .= ' ' x $self->offset->[$self->level];
385         $self->{stream} .= '-';
386         $self->_emit_node($val, FROMARRAY);
387     }
388     $self->{level}--;
389 }
390
391 # Emit a mapping key
392 sub _emit_key {
393     my $self = shift;
394     my ($value, $context) = @_;
395     $self->{stream} .= ' ' x $self->offset->[$self->level]
396       unless $context == FROMARRAY;
397     $self->_emit_str($value, KEY);
398 }
399
400 # Emit a blessed SCALAR
401 sub _emit_scalar {
402     my $self = shift;
403     my ($value, $tag) = @_;
404     $self->{stream} .= " !$tag";
405     $self->_emit_str($value, BLESSED);
406 }
407
408 sub _emit {
409     my $self = shift;
410     $self->{stream} .= join '', @_;
411 }
412
413 # Emit a string value. YAML has many scalar styles. This routine attempts to
414 # guess the best style for the text.
415 sub _emit_str {
416     my $self = shift;
417     my $type = $_[1] || 0;
418
419     # Use heuristics to find the best scalar emission style.
420     $self->offset->[$self->level + 1] =
421       $self->offset->[$self->level] + $self->indent_width;
422     $self->{level}++;
423
424     my $sf = $type == KEY ? '' : ' ';
425     my $sb = $type == KEY ? '? ' : ' ';
426     my $ef = $type == KEY ? '' : "\n";
427     my $eb = "\n";
428
429     while (1) {
430         $self->_emit($sf),
431         $self->_emit_plain($_[0]),
432         $self->_emit($ef), last
433           if not defined $_[0];
434         $self->_emit($sf, '=', $ef), last
435           if $_[0] eq VALUE;
436         $self->_emit($sf),
437         $self->_emit_double($_[0]),
438         $self->_emit($ef), last
439           if $_[0] =~ /$ESCAPE_CHAR/;
440         if ($_[0] =~ /\n/) {
441             $self->_emit($sb),
442             $self->_emit_block($LIT_CHAR, $_[0]),
443             $self->_emit($eb), last
444               if $self->use_block;
445               Carp::cluck "[YAML] \$UseFold is no longer supported"
446               if $self->use_fold;
447             $self->_emit($sf),
448             $self->_emit_double($_[0]),
449             $self->_emit($ef), last
450               if length $_[0] <= 30;
451             $self->_emit($sf),
452             $self->_emit_double($_[0]),
453             $self->_emit($ef), last
454               if $_[0] !~ /\n\s*\S/;
455             $self->_emit($sb),
456             $self->_emit_block($LIT_CHAR, $_[0]),
457             $self->_emit($eb), last;
458         }
459         $self->_emit($sf),
460         $self->_emit_number($_[0]),
461         $self->_emit($ef), last
462           if $self->is_literal_number($_[0]);
463         $self->_emit($sf),
464         $self->_emit_plain($_[0]),
465         $self->_emit($ef), last
466           if $self->is_valid_plain($_[0]);
467         $self->_emit($sf),
468         $self->_emit_double($_[0]),
469         $self->_emit($ef), last
470           if $_[0] =~ /'/;
471         $self->_emit($sf),
472         $self->_emit_single($_[0]),
473         $self->_emit($ef);
474         last;
475     }
476
477     $self->{level}--;
478
479     return;
480 }
481
482 sub is_literal_number {
483     my $self = shift;
484     # Stolen from JSON::Tiny
485     return B::svref_2object(\$_[0])->FLAGS & (B::SVp_IOK | B::SVp_NOK)
486             && 0 + $_[0] eq $_[0];
487 }
488
489 sub _emit_number {
490     my $self = shift;
491     return $self->_emit_plain($_[0]);
492 }
493
494 # Check whether or not a scalar should be emitted as an plain scalar.
495 sub is_valid_plain {
496     my $self = shift;
497     return 0 unless length $_[0];
498     return 0 if $self->quote_numeric_strings and Scalar::Util::looks_like_number($_[0]);
499     # refer to YAML::Loader::parse_inline_simple()
500     return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/;
501     return 0 if $_[0] =~ /[\{\[\]\},]/;
502     return 0 if $_[0] =~ /[:\-\?]\s/;
503     return 0 if $_[0] =~ /\s#/;
504     return 0 if $_[0] =~ /\:(\s|$)/;
505     return 0 if $_[0] =~ /[\s\|\>]$/;
506     return 0 if $_[0] eq '-';
507     return 1;
508 }
509
510 sub _emit_block {
511     my $self = shift;
512     my ($indicator, $value) = @_;
513     $self->{stream} .= $indicator;
514     $value =~ /(\n*)\Z/;
515     my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
516     $value = '~' if not defined $value;
517     $self->{stream} .= $chomp;
518     $self->{stream} .= $self->indent_width if $value =~ /^\s/;
519     $self->{stream} .= $self->indent($value);
520 }
521
522 # Plain means that the scalar is unquoted.
523 sub _emit_plain {
524     my $self = shift;
525     $self->{stream} .= defined $_[0] ? $_[0] : '~';
526 }
527
528 # Double quoting is for single lined escaped strings.
529 sub _emit_double {
530     my $self = shift;
531     (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
532     $self->{stream} .= qq{"$escaped"};
533 }
534
535 # Single quoting is for single lined unescaped strings.
536 sub _emit_single {
537     my $self = shift;
538     my $item = shift;
539     $item =~ s{'}{''}g;
540     $self->{stream} .= "'$item'";
541 }
542
543 #==============================================================================
544 # Utility subroutines.
545 #==============================================================================
546
547 # Indent a scalar to the current indentation level.
548 sub indent {
549     my $self = shift;
550     my ($text) = @_;
551     return $text unless length $text;
552     $text =~ s/\n\Z//;
553     my $indent = ' ' x $self->offset->[$self->level];
554     $text =~ s/^/$indent/gm;
555     $text = "\n$text";
556     return $text;
557 }
558
559 # Escapes for unprintable characters
560 my @escapes = qw(\0   \x01 \x02 \x03 \x04 \x05 \x06 \a
561                  \x08 \t   \n   \v   \f   \r   \x0e \x0f
562                  \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
563                  \x18 \x19 \x1a \e   \x1c \x1d \x1e \x1f
564                 );
565
566 # Escape the unprintable characters
567 sub escape {
568     my $self = shift;
569     my ($text) = @_;
570     $text =~ s/\\/\\\\/g;
571     $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
572     return $text;
573 }
574
575 1;