Revision c6bc1816
Von Sven Schöling vor etwa 9 Jahren hinzugefügt
| modules/override/YAML/Dumper.pm | ||
|---|---|---|
| 1 | 1 |
package YAML::Dumper; |
| 2 |
use strict; use warnings; |
|
| 3 |
use YAML::Base; |
|
| 4 |
use base 'YAML::Dumper::Base'; |
|
| 5 | 2 |
|
| 3 |
use YAML::Mo; |
|
| 4 |
extends 'YAML::Dumper::Base'; |
|
| 5 |
|
|
| 6 |
use YAML::Dumper::Base; |
|
| 6 | 7 |
use YAML::Node; |
| 7 | 8 |
use YAML::Types; |
| 9 |
use Scalar::Util qw(); |
|
| 8 | 10 |
|
| 9 | 11 |
# Context constants |
| 10 |
use constant KEY => 3; |
|
| 11 |
use constant BLESSED => 4; |
|
| 12 |
use constant KEY => 3;
|
|
| 13 |
use constant BLESSED => 4;
|
|
| 12 | 14 |
use constant FROMARRAY => 5; |
| 13 |
use constant VALUE => "\x07YAML\x07VALUE\x07"; |
|
| 15 |
use constant VALUE => "\x07YAML\x07VALUE\x07";
|
|
| 14 | 16 |
|
| 15 | 17 |
# Common YAML character sets |
| 16 | 18 |
my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; |
| 17 |
my $LIT_CHAR = '|';
|
|
| 19 |
my $LIT_CHAR = '|';
|
|
| 18 | 20 |
|
| 19 | 21 |
#============================================================================== |
| 20 |
# OO version of Dump. YAML->new->dump($foo);
|
|
| 22 |
# OO version of Dump. YAML->new->dump($foo); |
|
| 21 | 23 |
sub dump {
|
| 22 | 24 |
my $self = shift; |
| 23 | 25 |
$self->stream('');
|
| ... | ... | |
| 42 | 44 |
sub _emit_header {
|
| 43 | 45 |
my $self = shift; |
| 44 | 46 |
my ($node) = @_; |
| 45 |
if (not $self->use_header and
|
|
| 47 |
if (not $self->use_header and |
|
| 46 | 48 |
$self->document == 1 |
| 47 | 49 |
) {
|
| 48 | 50 |
$self->die('YAML_DUMP_ERR_NO_HEADER')
|
| ... | ... | |
| 79 | 81 |
} |
| 80 | 82 |
|
| 81 | 83 |
# Handle regexps |
| 82 |
if (ref($_[0]) eq 'Regexp') {
|
|
| 83 |
$self->transferred->{$node_id} =
|
|
| 84 |
YAML::Type::regexp->yaml_dump($_[0], $class, $self); |
|
| 84 |
if (ref($_[0]) eq 'Regexp') {
|
|
| 85 | 85 |
return; |
| 86 | 86 |
} |
| 87 | 87 |
|
| ... | ... | |
| 113 | 113 |
$self->transferred->{$node_id} = 'placeholder';
|
| 114 | 114 |
YAML::Type::code->yaml_dump( |
| 115 | 115 |
$self->dump_code, |
| 116 |
$_[0],
|
|
| 116 |
$_[0], |
|
| 117 | 117 |
$self->transferred->{$node_id}
|
| 118 | 118 |
); |
| 119 |
($class, $type, $node_id) =
|
|
| 119 |
($class, $type, $node_id) = |
|
| 120 | 120 |
$self->node_info(\ $self->transferred->{$node_id}, $stringify);
|
| 121 | 121 |
$self->{id_refcnt}{$node_id}++;
|
| 122 | 122 |
return; |
| ... | ... | |
| 144 | 144 |
} |
| 145 | 145 |
|
| 146 | 146 |
# Handle YAML Blessed things |
| 147 |
require YAML; |
|
| 147 | 148 |
if (defined YAML->global_object()->{blessed_map}{$node_id}) {
|
| 148 | 149 |
$value = YAML->global_object()->{blessed_map}{$node_id};
|
| 149 | 150 |
$self->transferred->{$node_id} = $value;
|
| ... | ... | |
| 164 | 165 |
my $ref_ynode = $self->transferred->{$node_id} =
|
| 165 | 166 |
YAML::Type::ref->yaml_dump($value); |
| 166 | 167 |
|
| 167 |
my $glob_ynode = $ref_ynode->{&VALUE} =
|
|
| 168 |
my $glob_ynode = $ref_ynode->{&VALUE} =
|
|
| 168 | 169 |
YAML::Type::glob->yaml_dump($$value); |
| 169 | 170 |
|
| 170 | 171 |
(undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify); |
| ... | ... | |
| 209 | 210 |
my $self = shift; |
| 210 | 211 |
my ($type, $node_id); |
| 211 | 212 |
my $ref = ref($_[0]); |
| 212 |
if ($ref and $ref ne 'Regexp') {
|
|
| 213 |
if ($ref) {
|
|
| 214 |
if ($ref eq 'Regexp') {
|
|
| 215 |
$self->_emit(' !!perl/regexp');
|
|
| 216 |
$self->_emit_str("$_[0]");
|
|
| 217 |
return; |
|
| 218 |
} |
|
| 213 | 219 |
(undef, $type, $node_id) = $self->node_info($_[0], $self->stringify); |
| 214 | 220 |
} |
| 215 | 221 |
else {
|
| ... | ... | |
| 232 | 238 |
$ynode = ynode($self->transferred->{$node_id});
|
| 233 | 239 |
$tag = defined $ynode ? $ynode->tag->short : ''; |
| 234 | 240 |
$type = 'SCALAR'; |
| 235 |
(undef, undef, $node_id) =
|
|
| 241 |
(undef, undef, $node_id) = |
|
| 236 | 242 |
$self->node_info( |
| 237 | 243 |
\ $self->transferred->{$node_id},
|
| 238 | 244 |
$self->stringify |
| ... | ... | |
| 270 | 276 |
return $self->_emit_str("$value");
|
| 271 | 277 |
} |
| 272 | 278 |
|
| 273 |
# A YAML mapping is akin to a Perl hash.
|
|
| 279 |
# A YAML mapping is akin to a Perl hash. |
|
| 274 | 280 |
sub _emit_mapping {
|
| 275 | 281 |
my $self = shift; |
| 276 | 282 |
my ($value, $tag, $node_id, $context) = @_; |
| ... | ... | |
| 351 | 357 |
$self->{stream} .= " !$tag" if $tag;
|
| 352 | 358 |
|
| 353 | 359 |
return ($self->{stream} .= " []\n") if @$value == 0;
|
| 354 |
|
|
| 360 |
|
|
| 355 | 361 |
$self->{stream} .= "\n"
|
| 356 | 362 |
unless $self->headless && not($self->headless(0)); |
| 357 | 363 |
|
| ... | ... | |
| 423 | 429 |
while (1) {
|
| 424 | 430 |
$self->_emit($sf), |
| 425 | 431 |
$self->_emit_plain($_[0]), |
| 426 |
$self->_emit($ef), last
|
|
| 432 |
$self->_emit($ef), last |
|
| 427 | 433 |
if not defined $_[0]; |
| 428 | 434 |
$self->_emit($sf, '=', $ef), last |
| 429 | 435 |
if $_[0] eq VALUE; |
| ... | ... | |
| 451 | 457 |
$self->_emit($eb), last; |
| 452 | 458 |
} |
| 453 | 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), |
|
| 454 | 464 |
$self->_emit_plain($_[0]), |
| 455 | 465 |
$self->_emit($ef), last |
| 456 | 466 |
if $self->is_valid_plain($_[0]); |
| ... | ... | |
| 469 | 479 |
return; |
| 470 | 480 |
} |
| 471 | 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 |
|
|
| 472 | 494 |
# Check whether or not a scalar should be emitted as an plain scalar. |
| 473 | 495 |
sub is_valid_plain {
|
| 474 | 496 |
my $self = shift; |
| 475 | 497 |
return 0 unless length $_[0]; |
| 498 |
return 0 if $self->quote_numeric_strings and Scalar::Util::looks_like_number($_[0]); |
|
| 476 | 499 |
# refer to YAML::Loader::parse_inline_simple() |
| 477 | 500 |
return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/;
|
| 478 | 501 |
return 0 if $_[0] =~ /[\{\[\]\},]/;
|
| ... | ... | |
| 480 | 503 |
return 0 if $_[0] =~ /\s#/; |
| 481 | 504 |
return 0 if $_[0] =~ /\:(\s|$)/; |
| 482 | 505 |
return 0 if $_[0] =~ /[\s\|\>]$/; |
| 506 |
return 0 if $_[0] eq '-'; |
|
| 483 | 507 |
return 1; |
| 484 | 508 |
} |
| 485 | 509 |
|
| ... | ... | |
| 533 | 557 |
} |
| 534 | 558 |
|
| 535 | 559 |
# Escapes for unprintable characters |
| 536 |
my @escapes = qw(\z \x01 \x02 \x03 \x04 \x05 \x06 \a
|
|
| 560 |
my @escapes = qw(\0 \x01 \x02 \x03 \x04 \x05 \x06 \a
|
|
| 537 | 561 |
\x08 \t \n \v \f \r \x0e \x0f |
| 538 | 562 |
\x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17 |
| 539 | 563 |
\x18 \x19 \x1a \e \x1c \x1d \x1e \x1f |
| ... | ... | |
| 549 | 573 |
} |
| 550 | 574 |
|
| 551 | 575 |
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 |
|
Auch abrufbar als: Unified diff
YAML: Versionsupdate