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;