2 use strict; use warnings;
4 use base 'YAML::Dumper::Base';
10 use constant KEY => 3;
11 use constant BLESSED => 4;
12 use constant FROMARRAY => 5;
13 use constant VALUE => "\x07YAML\x07VALUE\x07";
15 # Common YAML character sets
16 my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
19 #==============================================================================
20 # OO version of Dump. YAML->new->dump($foo);
25 for my $document (@_) {
27 $self->transferred({});
32 $self->offset->[0] = 0 - $self->indent_width;
33 $self->_prewalk($document);
34 $self->_emit_header($document);
35 $self->_emit_node($document);
40 # Every YAML document in the stream must begin with a YAML header, unless
41 # there is only a single document and the user requests "no header".
45 if (not $self->use_header and
48 $self->die('YAML_DUMP_ERR_NO_HEADER')
49 unless ref($node) =~ /^(HASH|ARRAY)$/;
50 $self->die('YAML_DUMP_ERR_NO_HEADER')
51 if ref($node) eq 'HASH' and keys(%$node) == 0;
52 $self->die('YAML_DUMP_ERR_NO_HEADER')
53 if ref($node) eq 'ARRAY' and @$node == 0;
54 # XXX Also croak if aliased, blessed, or ynode
58 $self->{stream} .= '---';
59 # XXX Consider switching to 1.1 style
60 if ($self->use_version) {
61 # $self->{stream} .= " #YAML:1.0";
65 # Walk the tree to be dumped and keep track of its reference counts.
66 # This function is where the Dumper does all its work. All type
67 # transfers happen here.
70 my $stringify = $self->stringify;
71 my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
74 if ($type eq 'GLOB') {
75 $self->transferred->{$node_id} =
76 YAML::Type::glob->yaml_dump($_[0]);
77 $self->_prewalk($self->transferred->{$node_id});
82 if (ref($_[0]) eq 'Regexp') {
83 $self->transferred->{$node_id} =
84 YAML::Type::regexp->yaml_dump($_[0], $class, $self);
88 # Handle Purity for scalars.
89 # XXX can't find a use case yet. Might be YAGNI.
91 $self->{id_refcnt}{$node_id}++ if $self->purity;
95 # Make a copy of original
97 ($class, $type, $node_id) = $self->node_info($value, $stringify);
99 # Must be a stringified object.
100 return if (ref($value) and not $type);
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}++;
112 if ($type eq 'CODE') {
113 $self->transferred->{$node_id} = 'placeholder';
114 YAML::Type::code->yaml_dump(
117 $self->transferred->{$node_id}
119 ($class, $type, $node_id) =
120 $self->node_info(\ $self->transferred->{$node_id}, $stringify);
121 $self->{id_refcnt}{$node_id}++;
125 # Handle blessed things
126 if (defined $class) {
127 if ($value->can('yaml_dump')) {
128 $value = $value->yaml_dump;
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}++;
140 $value = YAML::Type::blessed->yaml_dump($value);
142 $self->transferred->{$node_id} = $value;
143 (undef, $type, $node_id) = $self->node_info($value, $stringify);
146 # Handle YAML Blessed things
147 if (defined YAML->global_object()->{blessed_map}{$node_id}) {
148 $value = YAML->global_object()->{blessed_map}{$node_id};
149 $self->transferred->{$node_id} = $value;
150 ($class, $type, $node_id) = $self->node_info($value, $stringify);
151 $self->_prewalk($value);
156 if ($type eq 'REF' or $type eq 'SCALAR') {
157 $value = YAML::Type::ref->yaml_dump($value);
158 $self->transferred->{$node_id} = $value;
159 (undef, $type, $node_id) = $self->node_info($value, $stringify);
162 # Handle ref-to-glob's
163 elsif ($type eq 'GLOB') {
164 my $ref_ynode = $self->transferred->{$node_id} =
165 YAML::Type::ref->yaml_dump($value);
167 my $glob_ynode = $ref_ynode->{&VALUE} =
168 YAML::Type::glob->yaml_dump($$value);
170 (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify);
171 $self->transferred->{$node_id} = $glob_ynode;
172 $self->_prewalk($glob_ynode);
176 # Increment ref count for node
177 return if ++($self->{id_refcnt}{$node_id}) > 1;
180 if ($type eq 'HASH') {
181 $self->_prewalk($value->{$_})
185 elsif ($type eq 'ARRAY') {
191 # Unknown type. Need to know about it.
192 $self->warn(<<"...");
193 YAML::Dumper can't handle dumping this type of data.
194 Please report this to the author.
206 # Every data element and sub data element is a node.
207 # Everything emitted goes through this function.
210 my ($type, $node_id);
211 my $ref = ref($_[0]);
212 if ($ref and $ref ne 'Regexp') {
213 (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify);
216 $type = $ref || 'SCALAR';
217 (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify);
220 my ($ynode, $tag) = ('') x 2;
221 my ($value, $context) = (@_, 0);
223 if (defined $self->transferred->{$node_id}) {
224 $value = $self->transferred->{$node_id};
225 $ynode = ynode($value);
227 $tag = defined $ynode ? $ynode->tag->short : '';
228 (undef, $type, $node_id) =
229 $self->node_info($value, $self->stringify);
232 $ynode = ynode($self->transferred->{$node_id});
233 $tag = defined $ynode ? $ynode->tag->short : '';
235 (undef, undef, $node_id) =
237 \ $self->transferred->{$node_id},
242 elsif ($ynode = ynode($value)) {
243 $tag = $ynode->tag->short;
246 if ($self->use_aliases) {
247 $self->{id_refcnt}{$node_id} ||= 0;
248 if ($self->{id_refcnt}{$node_id} > 1) {
249 if (defined $self->{id_anchor}{$node_id}) {
250 $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n";
253 my $anchor = $self->anchor_prefix . $self->{anchor}++;
254 $self->{stream} .= ' &' . $anchor;
255 $self->{id_anchor}{$node_id} = $anchor;
259 return $self->_emit_str("$value") # Stringified object
260 if ref($value) and not $type;
261 return $self->_emit_scalar($value, $tag)
262 if $type eq 'SCALAR' and $tag;
263 return $self->_emit_str($value)
264 if $type eq 'SCALAR';
265 return $self->_emit_mapping($value, $tag, $node_id, $context)
267 return $self->_emit_sequence($value, $tag)
269 $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type);
270 return $self->_emit_str("$value");
273 # A YAML mapping is akin to a Perl hash.
276 my ($value, $tag, $node_id, $context) = @_;
277 $self->{stream} .= " !$tag" if $tag;
279 # Sometimes 'keys' fails. Like on a bad tie implementation.
280 my $empty_hash = not(eval {keys %$value});
281 $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@;
282 return ($self->{stream} .= " {}\n") if $empty_hash;
284 # If CompressSeries is on (default) and legal is this context, then
285 # use it and make the indent level be 2 for this node.
286 if ($context == FROMARRAY and
287 $self->compress_series and
288 not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash)
290 $self->{stream} .= ' ';
291 $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2;
295 $self->{stream} .= "\n"
296 unless $self->headless && not($self->headless(0));
297 $self->offset->[$self->level+1] =
298 $self->offset->[$self->level] + $self->indent_width;
303 if ($self->sort_keys == 1) {
305 @keys = keys %$value;
308 @keys = sort keys %$value;
311 elsif ($self->sort_keys == 2) {
312 @keys = sort keys %$value;
314 # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
315 elsif (ref($self->sort_keys) eq 'ARRAY') {
317 my %order = map { ($_, $i++) } @{$self->sort_keys};
319 (defined $order{$a} and defined $order{$b})
320 ? ($order{$a} <=> $order{$b})
325 @keys = keys %$value;
327 # Force the YAML::VALUE ('=') key to sort last.
328 if (exists $value->{&VALUE}) {
329 for (my $i = 0; $i < @keys; $i++) {
330 if ($keys[$i] eq &VALUE) {
331 splice(@keys, $i, 1);
338 for my $key (@keys) {
339 $self->_emit_key($key, $context);
341 $self->{stream} .= ':';
342 $self->_emit_node($value->{$key});
347 # A YAML series is akin to a Perl array.
350 my ($value, $tag) = @_;
351 $self->{stream} .= " !$tag" if $tag;
353 return ($self->{stream} .= " []\n") if @$value == 0;
355 $self->{stream} .= "\n"
356 unless $self->headless && not($self->headless(0));
358 # XXX Really crufty feature. Better implemented by ynodes.
359 if ($self->inline_series and
360 @$value <= $self->inline_series and
361 not (scalar grep {ref or /\n/} @$value)
363 $self->{stream} =~ s/\n\Z/ /;
364 $self->{stream} .= '[';
365 for (my $i = 0; $i < @$value; $i++) {
366 $self->_emit_str($value->[$i], KEY);
367 last if $i == $#{$value};
368 $self->{stream} .= ', ';
370 $self->{stream} .= "]\n";
374 $self->offset->[$self->level + 1] =
375 $self->offset->[$self->level] + $self->indent_width;
377 for my $val (@$value) {
378 $self->{stream} .= ' ' x $self->offset->[$self->level];
379 $self->{stream} .= '-';
380 $self->_emit_node($val, FROMARRAY);
388 my ($value, $context) = @_;
389 $self->{stream} .= ' ' x $self->offset->[$self->level]
390 unless $context == FROMARRAY;
391 $self->_emit_str($value, KEY);
394 # Emit a blessed SCALAR
397 my ($value, $tag) = @_;
398 $self->{stream} .= " !$tag";
399 $self->_emit_str($value, BLESSED);
404 $self->{stream} .= join '', @_;
407 # Emit a string value. YAML has many scalar styles. This routine attempts to
408 # guess the best style for the text.
411 my $type = $_[1] || 0;
413 # Use heuristics to find the best scalar emission style.
414 $self->offset->[$self->level + 1] =
415 $self->offset->[$self->level] + $self->indent_width;
418 my $sf = $type == KEY ? '' : ' ';
419 my $sb = $type == KEY ? '? ' : ' ';
420 my $ef = $type == KEY ? '' : "\n";
425 $self->_emit_plain($_[0]),
426 $self->_emit($ef), last
427 if not defined $_[0];
428 $self->_emit($sf, '=', $ef), last
431 $self->_emit_double($_[0]),
432 $self->_emit($ef), last
433 if $_[0] =~ /$ESCAPE_CHAR/;
436 $self->_emit_block($LIT_CHAR, $_[0]),
437 $self->_emit($eb), last
439 Carp::cluck "[YAML] \$UseFold is no longer supported"
442 $self->_emit_double($_[0]),
443 $self->_emit($ef), last
444 if length $_[0] <= 30;
446 $self->_emit_double($_[0]),
447 $self->_emit($ef), last
448 if $_[0] !~ /\n\s*\S/;
450 $self->_emit_block($LIT_CHAR, $_[0]),
451 $self->_emit($eb), last;
454 $self->_emit_plain($_[0]),
455 $self->_emit($ef), last
456 if $self->is_valid_plain($_[0]);
458 $self->_emit_double($_[0]),
459 $self->_emit($ef), last
462 $self->_emit_single($_[0]),
472 # Check whether or not a scalar should be emitted as an plain scalar.
475 return 0 unless length $_[0];
476 # refer to YAML::Loader::parse_inline_simple()
477 return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/;
478 return 0 if $_[0] =~ /[\{\[\]\},]/;
479 return 0 if $_[0] =~ /[:\-\?]\s/;
480 return 0 if $_[0] =~ /\s#/;
481 return 0 if $_[0] =~ /\:(\s|$)/;
482 return 0 if $_[0] =~ /[\s\|\>]$/;
488 my ($indicator, $value) = @_;
489 $self->{stream} .= $indicator;
491 my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
492 $value = '~' if not defined $value;
493 $self->{stream} .= $chomp;
494 $self->{stream} .= $self->indent_width if $value =~ /^\s/;
495 $self->{stream} .= $self->indent($value);
498 # Plain means that the scalar is unquoted.
501 $self->{stream} .= defined $_[0] ? $_[0] : '~';
504 # Double quoting is for single lined escaped strings.
507 (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
508 $self->{stream} .= qq{"$escaped"};
511 # Single quoting is for single lined unescaped strings.
516 $self->{stream} .= "'$item'";
519 #==============================================================================
520 # Utility subroutines.
521 #==============================================================================
523 # Indent a scalar to the current indentation level.
527 return $text unless length $text;
529 my $indent = ' ' x $self->offset->[$self->level];
530 $text =~ s/^/$indent/gm;
535 # Escapes for unprintable characters
536 my @escapes = qw(\z \x01 \x02 \x03 \x04 \x05 \x06 \a
537 \x08 \t \n \v \f \r \x0e \x0f
538 \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
539 \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f
542 # Escape the unprintable characters
546 $text =~ s/\\/\\\\/g;
547 $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
557 YAML::Dumper - YAML class for dumping Perl objects to YAML
562 my $dumper = YAML::Dumper->new;
563 $dumper->indent_width(4);
564 print $dumper->dump({foo => 'bar'});
568 YAML::Dumper is the module that YAML.pm used to serialize Perl objects to
569 YAML. It is fully object oriented and usable on its own.
573 Ingy döt Net <ingy@cpan.org>
577 Copyright (c) 2006. Ingy döt Net. All rights reserved.
579 This program is free software; you can redistribute it and/or modify it
580 under the same terms as Perl itself.
582 See L<http://www.perl.com/perl/misc/Artistic.html>