Revision c6bc1816
Von Sven Schöling vor etwa 9 Jahren hinzugefügt
| modules/override/YAML/Loader.pm | ||
|---|---|---|
| 1 | 1 |
package YAML::Loader; |
| 2 |
use strict; use warnings; |
|
| 3 |
use YAML::Base; |
|
| 4 |
use base 'YAML::Loader::Base'; |
|
| 2 |
|
|
| 3 |
use YAML::Mo; |
|
| 4 |
extends 'YAML::Loader::Base'; |
|
| 5 |
|
|
| 6 |
use YAML::Loader::Base; |
|
| 5 | 7 |
use YAML::Types; |
| 6 | 8 |
|
| 7 | 9 |
# Context constants |
| 8 |
use constant LEAF => 1; |
|
| 10 |
use constant LEAF => 1;
|
|
| 9 | 11 |
use constant COLLECTION => 2; |
| 10 |
use constant VALUE => "\x07YAML\x07VALUE\x07"; |
|
| 11 |
use constant COMMENT => "\x07YAML\x07COMMENT\x07"; |
|
| 12 |
use constant VALUE => "\x07YAML\x07VALUE\x07";
|
|
| 13 |
use constant COMMENT => "\x07YAML\x07COMMENT\x07";
|
|
| 12 | 14 |
|
| 13 | 15 |
# Common YAML character sets |
| 14 | 16 |
my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; |
| 15 |
my $FOLD_CHAR = '>'; |
|
| 16 |
my $LIT_CHAR = '|'; |
|
| 17 |
my $FOLD_CHAR = '>';
|
|
| 18 |
my $LIT_CHAR = '|';
|
|
| 17 | 19 |
my $LIT_CHAR_RX = "\\$LIT_CHAR"; |
| 18 | 20 |
|
| 19 | 21 |
sub load {
|
| ... | ... | |
| 32 | 34 |
$self->line(0); |
| 33 | 35 |
$self->die('YAML_PARSE_ERR_BAD_CHARS')
|
| 34 | 36 |
if $self->stream =~ /$ESCAPE_CHAR/; |
| 35 |
# $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
|
|
| 36 |
$self->{stream} .= "\n"
|
|
| 37 |
$self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
|
|
| 37 | 38 |
if length($self->stream) and |
| 38 | 39 |
$self->{stream} !~ s/(.)\n\Z/$1/s;
|
| 39 | 40 |
$self->lines([split /\x0a/, $self->stream, -1]); |
| ... | ... | |
| 251 | 252 |
my $self = shift; |
| 252 | 253 |
my ($node, $explicit) = @_; |
| 253 | 254 |
my ($type, $class); |
| 254 |
if ($explicit =~ /^\!perl\/(hash|array|scalar)\:(\w(\w|\:\:)*)?$/) {
|
|
| 255 |
if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) {
|
|
| 255 | 256 |
($type, $class) = (($1 || ''), ($2 || '')); |
| 256 |
if (ref $node) {
|
|
| 257 |
return CORE::bless $node, $class; |
|
| 257 |
|
|
| 258 |
# FIXME # die unless uc($type) eq ref($node) ? |
|
| 259 |
|
|
| 260 |
if ( $type eq "ref" ) {
|
|
| 261 |
$self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit)
|
|
| 262 |
unless exists $node->{VALUE()} and scalar(keys %$node) == 1;
|
|
| 263 |
|
|
| 264 |
my $value = $node->{VALUE()};
|
|
| 265 |
$node = \$value; |
|
| 258 | 266 |
} |
| 259 |
else {
|
|
| 260 |
return CORE::bless \$node, $class; |
|
| 267 |
|
|
| 268 |
if ( $type eq "scalar" and length($class) and !ref($node) ) {
|
|
| 269 |
my $value = $node; |
|
| 270 |
$node = \$value; |
|
| 261 | 271 |
} |
| 272 |
|
|
| 273 |
if ( length($class) ) {
|
|
| 274 |
CORE::bless($node, $class); |
|
| 275 |
} |
|
| 276 |
|
|
| 277 |
return $node; |
|
| 262 | 278 |
} |
| 263 |
if ($explicit =~ |
|
| 264 |
/^\!?perl\/(undef|glob|regexp|code|ref)\:(\w(\w|\:\:)*)?$/) {
|
|
| 279 |
if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) {
|
|
| 265 | 280 |
($type, $class) = (($1 || ''), ($2 || '')); |
| 266 | 281 |
my $type_class = "YAML::Type::$type"; |
| 267 | 282 |
no strict 'refs'; |
| ... | ... | |
| 498 | 513 |
sub _parse_inline_double_quoted {
|
| 499 | 514 |
my $self = shift; |
| 500 | 515 |
my $node; |
| 501 |
if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) {
|
|
| 516 |
# https://rt.cpan.org/Public/Bug/Display.html?id=90593 |
|
| 517 |
if ($self->inline =~ /^"((?:(?:\\"|[^"]){0,32766}){0,32766})"\s*(.*)$/) {
|
|
| 502 | 518 |
$node = $1; |
| 503 | 519 |
$self->inline($2); |
| 504 | 520 |
$node =~ s/\\"/"/g; |
| ... | ... | |
| 514 | 530 |
sub _parse_inline_single_quoted {
|
| 515 | 531 |
my $self = shift; |
| 516 | 532 |
my $node; |
| 517 |
if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) {
|
|
| 533 |
if ($self->inline =~ /^'((?:(?:''|[^']){0,32766}){0,32766})'\s*(.*)$/) {
|
|
| 518 | 534 |
$node = $1; |
| 519 | 535 |
$self->inline($2); |
| 520 | 536 |
$node =~ s/''/'/g; |
| ... | ... | |
| 546 | 562 |
return $value if $value eq ''; |
| 547 | 563 |
return undef if $value =~ /^~$/; |
| 548 | 564 |
return $value |
| 549 |
unless $value =~ /^[\@\`\^]/ or
|
|
| 565 |
unless $value =~ /^[\@\`]/ or |
|
| 550 | 566 |
$value =~ /^[\-\?]\s/; |
| 551 | 567 |
$self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value);
|
| 552 | 568 |
} |
| ... | ... | |
| 630 | 646 |
else {
|
| 631 | 647 |
# First get rid of any comments. |
| 632 | 648 |
while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) {
|
| 633 |
$self->lines->[0] =~ /^( *)/ or die;
|
|
| 649 |
$self->lines->[0] =~ /^( *)/; |
|
| 634 | 650 |
last unless length($1) <= $offset; |
| 635 | 651 |
shift @{$self->lines};
|
| 636 | 652 |
$self->{line}++;
|
| ... | ... | |
| 655 | 671 |
return; |
| 656 | 672 |
} |
| 657 | 673 |
else {
|
| 658 |
$self->lines->[0] =~ /^( *)\S/ or die; |
|
| 674 |
$self->lines->[0] =~ /^( *)\S/ or |
|
| 675 |
$self->die('YAML_PARSE_ERR_NONSPACE_INDENTATION');
|
|
| 659 | 676 |
if (length($1) > $offset) {
|
| 660 | 677 |
$self->offset->[$level+1] = length($1); |
| 661 | 678 |
} |
| ... | ... | |
| 714 | 731 |
#============================================================================== |
| 715 | 732 |
|
| 716 | 733 |
# Printable characters for escapes |
| 717 |
my %unescapes = |
|
| 718 |
( |
|
| 719 |
z => "\x00", a => "\x07", t => "\x09", |
|
| 720 |
n => "\x0a", v => "\x0b", f => "\x0c", |
|
| 721 |
r => "\x0d", e => "\x1b", '\\' => '\\', |
|
| 734 |
my %unescapes = ( |
|
| 735 |
0 => "\x00", |
|
| 736 |
a => "\x07", |
|
| 737 |
t => "\x09", |
|
| 738 |
n => "\x0a", |
|
| 739 |
'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted |
|
| 740 |
f => "\x0c", |
|
| 741 |
r => "\x0d", |
|
| 742 |
e => "\x1b", |
|
| 743 |
'\\' => '\\', |
|
| 722 | 744 |
); |
| 723 | 745 |
|
| 724 | 746 |
# Transform all the backslash style escape characters to their literal meaning |
| 725 | 747 |
sub _unescape {
|
| 726 | 748 |
my $self = shift; |
| 727 | 749 |
my ($node) = @_; |
| 728 |
$node =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/
|
|
| 750 |
$node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
|
|
| 729 | 751 |
(length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
|
| 730 | 752 |
return $node; |
| 731 | 753 |
} |
| 732 | 754 |
|
| 733 | 755 |
1; |
| 734 |
|
|
| 735 |
__END__ |
|
| 736 |
|
|
| 737 |
=head1 NAME |
|
| 738 |
|
|
| 739 |
YAML::Loader - YAML class for loading Perl objects to YAML |
|
| 740 |
|
|
| 741 |
=head1 SYNOPSIS |
|
| 742 |
|
|
| 743 |
use YAML::Loader; |
|
| 744 |
my $loader = YAML::Loader->new; |
|
| 745 |
my $hash = $loader->load(<<'...'); |
|
| 746 |
foo: bar |
|
| 747 |
... |
|
| 748 |
|
|
| 749 |
=head1 DESCRIPTION |
|
| 750 |
|
|
| 751 |
YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl |
|
| 752 |
objects. It is fully object oriented and usable on its own. |
|
| 753 |
|
|
| 754 |
=head1 AUTHOR |
|
| 755 |
|
|
| 756 |
Ingy döt Net <ingy@cpan.org> |
|
| 757 |
|
|
| 758 |
=head1 COPYRIGHT |
|
| 759 |
|
|
| 760 |
Copyright (c) 2006. Ingy döt Net. All rights reserved. |
|
| 761 |
|
|
| 762 |
This program is free software; you can redistribute it and/or modify it |
|
| 763 |
under the same terms as Perl itself. |
|
| 764 |
|
|
| 765 |
See L<http://www.perl.com/perl/misc/Artistic.html> |
|
| 766 |
|
|
| 767 |
=cut |
|
Auch abrufbar als: Unified diff
YAML: Versionsupdate