modules/override/YAML/Dumper.pm

   1 package YAML::Dumper;
   2 use strict; use warnings;
   3 use YAML::Base;
   4 use base 'YAML::Dumper::Base';
   5
   6 use YAML::Node;
   7 use YAML::Types;
   8
   9 # Context constants
  10 use constant KEY => 3;
  11 use constant BLESSED => 4;
  12 use constant FROMARRAY => 5;
  13 use constant VALUE => "\x07YAML\x07VALUE\x07";
  14
  15 # Common YAML character sets
  16 my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
  17 my $LIT_CHAR = '|';
  18
  19 #==============================================================================
  20 # OO version of Dump. YAML->new->dump($foo);
  21 sub dump {
  22     my $self = shift;
  23     $self->stream('');
  24     $self->document(0);
  25     for my $document (@_) {
  26         $self->{document}++;
  27         $self->transferred({});
  28         $self->id_refcnt({});
  29         $self->id_anchor({});
  30         $self->anchor(1);
  31         $self->level(0);
  32         $self->offset->[0] = 0 - $self->indent_width;
  33         $self->_prewalk($document);
  34         $self->_emit_header($document);
  35         $self->_emit_node($document);
  36     }
  37     return $self->stream;
  38 }
  39
  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".
  42 sub _emit_header {
  43     my $self = shift;
  44     my ($node) = @_;
  45     if (not $self->use_header and
  46         $self->document == 1
  47        ) {
  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
  55         $self->headless(1);
  56         return;
  57     }
  58     $self->{stream} .= '---';
  59 # XXX Consider switching to 1.1 style
  60     if ($self->use_version) {
  61 #         $self->{stream} .= " #YAML:1.0";
  62     }
  63 }
  64
  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.
  68 sub _prewalk {
  69     my $self = shift;
  70     my $stringify = $self->stringify;
  71     my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify);
  72
  73     # Handle typeglobs
  74     if ($type eq 'GLOB') {
  75         $self->transferred->{$node_id} =
  76           YAML::Type::glob->yaml_dump($_[0]);
  77         $self->_prewalk($self->transferred->{$node_id});
  78         return;
  79     }
  80
  81     # Handle regexps
  82     if (ref($_[0]) eq 'Regexp') {
  83         $self->transferred->{$node_id} =
  84           YAML::Type::regexp->yaml_dump($_[0], $class, $self);
  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     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);
 152         return;
 153     }
 154
 155     # Handle hard refs
 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);
 160     }
 161
 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);
 166
 167         my $glob_ynode = $ref_ynode->{&VALUE} =
 168           YAML::Type::glob->yaml_dump($$value);
 169
 170         (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify);
 171         $self->transferred->{$node_id} = $glob_ynode;
 172         $self->_prewalk($glob_ynode);
 173         return;
 174     }
 175
 176     # Increment ref count for node
 177     return if ++($self->{id_refcnt}{$node_id}) > 1;
 178
 179     # Keep on walking
 180     if ($type eq 'HASH') {
 181         $self->_prewalk($value->{$_})
 182             for keys %{$value};
 183         return;
 184     }
 185     elsif ($type eq 'ARRAY') {
 186         $self->_prewalk($_)
 187             for @{$value};
 188         return;
 189     }
 190
 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.
 195
 196 id:    $node_id
 197 type:  $type
 198 class: $class
 199 value: $value
 200
 201 ...
 202
 203     return;
 204 }
 205
 206 # Every data element and sub data element is a node.
 207 # Everything emitted goes through this function.
 208 sub _emit_node {
 209     my $self = shift;
 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);
 214     }
 215     else {
 216         $type = $ref || 'SCALAR';
 217         (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify);
 218     }
 219
 220     my ($ynode, $tag) = ('') x 2;
 221     my ($value, $context) = (@_, 0);
 222
 223     if (defined $self->transferred->{$node_id}) {
 224         $value = $self->transferred->{$node_id};
 225         $ynode = ynode($value);
 226         if (ref $value) {
 227             $tag = defined $ynode ? $ynode->tag->short : '';
 228             (undef, $type, $node_id) =
 229               $self->node_info($value, $self->stringify);
 230         }
 231         else {
 232             $ynode = ynode($self->transferred->{$node_id});
 233             $tag = defined $ynode ? $ynode->tag->short : '';
 234             $type = 'SCALAR';
 235             (undef, undef, $node_id) =
 236               $self->node_info(
 237                   \ $self->transferred->{$node_id},
 238                   $self->stringify
 239               );
 240         }
 241     }
 242     elsif ($ynode = ynode($value)) {
 243         $tag = $ynode->tag->short;
 244     }
 245
 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";
 251                 return;
 252             }
 253             my $anchor = $self->anchor_prefix . $self->{anchor}++;
 254             $self->{stream} .= ' &' . $anchor;
 255             $self->{id_anchor}{$node_id} = $anchor;
 256         }
 257     }
 258
 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)
 266       if $type eq 'HASH';
 267     return $self->_emit_sequence($value, $tag)
 268       if $type eq 'ARRAY';
 269     $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type);
 270     return $self->_emit_str("$value");
 271 }
 272
 273 # A YAML mapping is akin to a Perl hash.
 274 sub _emit_mapping {
 275     my $self = shift;
 276     my ($value, $tag, $node_id, $context) = @_;
 277     $self->{stream} .= " !$tag" if $tag;
 278
 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;
 283
 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)
 289        ) {
 290         $self->{stream} .= ' ';
 291         $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2;
 292     }
 293     else {
 294         $context = 0;
 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;
 299     }
 300
 301     $self->{level}++;
 302     my @keys;
 303     if ($self->sort_keys == 1) {
 304         if (ynode($value)) {
 305             @keys = keys %$value;
 306         }
 307         else {
 308             @keys = sort keys %$value;
 309         }
 310     }
 311     elsif ($self->sort_keys == 2) {
 312         @keys = sort keys %$value;
 313     }
 314     # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
 315     elsif (ref($self->sort_keys) eq 'ARRAY') {
 316         my $i = 1;
 317         my %order = map { ($_, $i++) } @{$self->sort_keys};
 318         @keys = sort {
 319             (defined $order{$a} and defined $order{$b})
 320               ? ($order{$a} <=> $order{$b})
 321               : ($a cmp $b);
 322         } keys %$value;
 323     }
 324     else {
 325         @keys = keys %$value;
 326     }
 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);
 332                 push @keys, &VALUE;
 333                 last;
 334             }
 335         }
 336     }
 337
 338     for my $key (@keys) {
 339         $self->_emit_key($key, $context);
 340         $context = 0;
 341         $self->{stream} .= ':';
 342         $self->_emit_node($value->{$key});
 343     }
 344     $self->{level}--;
 345 }
 346
 347 # A YAML series is akin to a Perl array.
 348 sub _emit_sequence {
 349     my $self = shift;
 350     my ($value, $tag) = @_;
 351     $self->{stream} .= " !$tag" if $tag;
 352
 353     return ($self->{stream} .= " []\n") if @$value == 0;
 354
 355     $self->{stream} .= "\n"
 356       unless $self->headless && not($self->headless(0));
 357
 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)
 362        ) {
 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} .= ', ';
 369         }
 370         $self->{stream} .= "]\n";
 371         return;
 372     }
 373
 374     $self->offset->[$self->level + 1] =
 375       $self->offset->[$self->level] + $self->indent_width;
 376     $self->{level}++;
 377     for my $val (@$value) {
 378         $self->{stream} .= ' ' x $self->offset->[$self->level];
 379         $self->{stream} .= '-';
 380         $self->_emit_node($val, FROMARRAY);
 381     }
 382     $self->{level}--;
 383 }
 384
 385 # Emit a mapping key
 386 sub _emit_key {
 387     my $self = shift;
 388     my ($value, $context) = @_;
 389     $self->{stream} .= ' ' x $self->offset->[$self->level]
 390       unless $context == FROMARRAY;
 391     $self->_emit_str($value, KEY);
 392 }
 393
 394 # Emit a blessed SCALAR
 395 sub _emit_scalar {
 396     my $self = shift;
 397     my ($value, $tag) = @_;
 398     $self->{stream} .= " !$tag";
 399     $self->_emit_str($value, BLESSED);
 400 }
 401
 402 sub _emit {
 403     my $self = shift;
 404     $self->{stream} .= join '', @_;
 405 }
 406
 407 # Emit a string value. YAML has many scalar styles. This routine attempts to
 408 # guess the best style for the text.
 409 sub _emit_str {
 410     my $self = shift;
 411     my $type = $_[1] || 0;
 412
 413     # Use heuristics to find the best scalar emission style.
 414     $self->offset->[$self->level + 1] =
 415       $self->offset->[$self->level] + $self->indent_width;
 416     $self->{level}++;
 417
 418     my $sf = $type == KEY ? '' : ' ';
 419     my $sb = $type == KEY ? '? ' : ' ';
 420     my $ef = $type == KEY ? '' : "\n";
 421     my $eb = "\n";
 422
 423     while (1) {
 424         $self->_emit($sf),
 425         $self->_emit_plain($_[0]),
 426         $self->_emit($ef), last
 427           if not defined $_[0];
 428         $self->_emit($sf, '=', $ef), last
 429           if $_[0] eq VALUE;
 430         $self->_emit($sf),
 431         $self->_emit_double($_[0]),
 432         $self->_emit($ef), last
 433           if $_[0] =~ /$ESCAPE_CHAR/;
 434         if ($_[0] =~ /\n/) {
 435             $self->_emit($sb),
 436             $self->_emit_block($LIT_CHAR, $_[0]),
 437             $self->_emit($eb), last
 438               if $self->use_block;
 439               Carp::cluck "[YAML] \$UseFold is no longer supported"
 440               if $self->use_fold;
 441             $self->_emit($sf),
 442             $self->_emit_double($_[0]),
 443             $self->_emit($ef), last
 444               if length $_[0] <= 30;
 445             $self->_emit($sf),
 446             $self->_emit_double($_[0]),
 447             $self->_emit($ef), last
 448               if $_[0] !~ /\n\s*\S/;
 449             $self->_emit($sb),
 450             $self->_emit_block($LIT_CHAR, $_[0]),
 451             $self->_emit($eb), last;
 452         }
 453         $self->_emit($sf),
 454         $self->_emit_plain($_[0]),
 455         $self->_emit($ef), last
 456           if $self->is_valid_plain($_[0]);
 457         $self->_emit($sf),
 458         $self->_emit_double($_[0]),
 459         $self->_emit($ef), last
 460           if $_[0] =~ /'/;
 461         $self->_emit($sf),
 462         $self->_emit_single($_[0]),
 463         $self->_emit($ef);
 464         last;
 465     }
 466
 467     $self->{level}--;
 468
 469     return;
 470 }
 471
 472 # Check whether or not a scalar should be emitted as an plain scalar.
 473 sub is_valid_plain {
 474     my $self = shift;
 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\|\>]$/;
 483     return 1;
 484 }
 485
 486 sub _emit_block {
 487     my $self = shift;
 488     my ($indicator, $value) = @_;
 489     $self->{stream} .= $indicator;
 490     $value =~ /(\n*)\Z/;
 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);
 496 }
 497
 498 # Plain means that the scalar is unquoted.
 499 sub _emit_plain {
 500     my $self = shift;
 501     $self->{stream} .= defined $_[0] ? $_[0] : '~';
 502 }
 503
 504 # Double quoting is for single lined escaped strings.
 505 sub _emit_double {
 506     my $self = shift;
 507     (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g;
 508     $self->{stream} .= qq{"$escaped"};
 509 }
 510
 511 # Single quoting is for single lined unescaped strings.
 512 sub _emit_single {
 513     my $self = shift;
 514     my $item = shift;
 515     $item =~ s{'}{''}g;
 516     $self->{stream} .= "'$item'";
 517 }
 518
 519 #==============================================================================
 520 # Utility subroutines.
 521 #==============================================================================
 522
 523 # Indent a scalar to the current indentation level.
 524 sub indent {
 525     my $self = shift;
 526     my ($text) = @_;
 527     return $text unless length $text;
 528     $text =~ s/\n\Z//;
 529     my $indent = ' ' x $self->offset->[$self->level];
 530     $text =~ s/^/$indent/gm;
 531     $text = "\n$text";
 532     return $text;
 533 }
 534
 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
 540                 );
 541
 542 # Escape the unprintable characters
 543 sub escape {
 544     my $self = shift;
 545     my ($text) = @_;
 546     $text =~ s/\\/\\\\/g;
 547     $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
 548     return $text;
 549 }
 550
 551 1;
 552
 553 __END__
 554
 555 =head1 NAME
 556
 557 YAML::Dumper - YAML class for dumping Perl objects to YAML
 558
 559 =head1 SYNOPSIS
 560
 561     use YAML::Dumper;
 562     my $dumper = YAML::Dumper->new;
 563     $dumper->indent_width(4);
 564     print $dumper->dump({foo => 'bar'});
 565
 566 =head1 DESCRIPTION
 567
 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.
 570
 571 =head1 AUTHOR
 572
 573 Ingy döt Net <ingy@cpan.org>
 574
 575 =head1 COPYRIGHT
 576
 577 Copyright (c) 2006. Ingy döt Net. All rights reserved.
 578
 579 This program is free software; you can redistribute it and/or modify it
 580 under the same terms as Perl itself.
 581
 582 See L<http://www.perl.com/perl/misc/Artistic.html>
 583
 584 =cut