package YAML::Loader;
-use strict; use warnings;
-use YAML::Base;
-use base 'YAML::Loader::Base';
+
+use YAML::Mo;
+extends 'YAML::Loader::Base';
+
+use YAML::Loader::Base;
use YAML::Types;
# Context constants
-use constant LEAF => 1;
+use constant LEAF => 1;
use constant COLLECTION => 2;
-use constant VALUE => "\x07YAML\x07VALUE\x07";
-use constant COMMENT => "\x07YAML\x07COMMENT\x07";
+use constant VALUE => "\x07YAML\x07VALUE\x07";
+use constant COMMENT => "\x07YAML\x07COMMENT\x07";
# Common YAML character sets
my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
-my $FOLD_CHAR = '>';
-my $LIT_CHAR = '|';
-my $LIT_CHAR_RX = "\\$LIT_CHAR";
+my $FOLD_CHAR = '>';
+my $LIT_CHAR = '|';
+my $LIT_CHAR_RX = "\\$LIT_CHAR";
sub load {
my $self = shift;
$self->{stream} =~ s|\015\012|\012|g;
$self->{stream} =~ s|\015|\012|g;
$self->line(0);
- $self->die('YAML_PARSE_ERR_BAD_CHARS')
+ $self->die('YAML_PARSE_ERR_BAD_CHARS')
if $self->stream =~ /$ESCAPE_CHAR/;
- $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
- if length($self->stream) and
+# $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
+ $self->{stream} .= "\n"
+ if length($self->stream) and
$self->{stream} !~ s/(.)\n\Z/$1/s;
$self->lines([split /\x0a/, $self->stream, -1]);
$self->line(1);
$directives{YAML} ||= '1.0';
$directives{TAB} ||= 'NONE';
- ($self->{major_version}, $self->{minor_version}) =
+ ($self->{major_version}, $self->{minor_version}) =
split /\./, $directives{YAML}, 2;
$self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML})
if $self->major_version ne '1';
$self->preface('');
my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
- ($anchor, $alias, $explicit, $implicit, $preface) =
+ ($anchor, $alias, $explicit, $implicit, $preface) =
$self->_parse_qualifiers($preface);
if ($anchor) {
$self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
$self->inline('');
while (length $preface) {
my $line = $self->line - 1;
- if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
+ if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
$indicator = $1;
$chomp = $2 if defined($2);
}
}
else {
$node = do {my $sv = "*$alias"};
- push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
+ push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
}
}
elsif (length $self->inline) {
$node = $self->_parse_inline(1, $implicit, $explicit);
if (length $self->inline) {
- $self->die('YAML_PARSE_ERR_SINGLE_LINE');
+ $self->die('YAML_PARSE_ERR_SINGLE_LINE');
}
}
elsif ($indicator eq $LIT_CHAR) {
$self->{level}++;
$node = $self->_parse_block($chomp);
$node = $self->_parse_implicit($node) if $implicit;
- $self->{level}--;
+ $self->{level}--;
}
elsif ($indicator eq $FOLD_CHAR) {
$self->{level}++;
}
elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
$token = $1;
- $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
+ $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
unless $token =~ /^[a-zA-Z0-9]+$/;
$self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor;
$self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias;
$alias = $token;
}
}
- return ($anchor, $alias, $explicit, $implicit, $preface);
+ return ($anchor, $alias, $explicit, $implicit, $preface);
}
-# Morph a node to it's explicit type
+# Morph a node to it's explicit type
sub _parse_explicit {
my $self = shift;
my ($node, $explicit) = @_;
my ($type, $class);
- if ($explicit =~ /^\!perl\/(hash|array|scalar)\:(\w(\w|\:\:)*)?$/) {
+ if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) {
($type, $class) = (($1 || ''), ($2 || ''));
- if (ref $node) {
- return CORE::bless $node, $class;
+
+ # FIXME # die unless uc($type) eq ref($node) ?
+
+ if ( $type eq "ref" ) {
+ $self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit)
+ unless exists $node->{VALUE()} and scalar(keys %$node) == 1;
+
+ my $value = $node->{VALUE()};
+ $node = \$value;
}
- else {
- return CORE::bless \$node, $class;
+
+ if ( $type eq "scalar" and length($class) and !ref($node) ) {
+ my $value = $node;
+ $node = \$value;
}
+
+ if ( length($class) ) {
+ CORE::bless($node, $class);
+ }
+
+ return $node;
}
- if ($explicit =~
- /^\!?perl\/(undef|glob|regexp|code|ref)\:(\w(\w|\:\:)*)?$/) {
+ if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) {
($type, $class) = (($1 || ''), ($2 || ''));
my $type_class = "YAML::Type::$type";
no strict 'refs';
$key = $self->_parse_node();
$key = "$key";
}
- # If "default" key (equals sign)
+ # If "default" key (equals sign)
elsif ($self->{content} =~ s/^\=\s*//) {
$key = VALUE;
}
$self->content($self->inline);
$self->inline('');
}
-
+
unless ($self->{content} =~ s/^:\s*//) {
$self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
}
my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
$self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
- ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
+ ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
$self->_parse_qualifiers($self->inline);
if ($anchor) {
$self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
}
else {
$node = do {my $sv = "*$alias"};
- push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
+ push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
}
}
elsif ($self->inline =~ /^\{/) {
my $value = $self->_parse_inline();
push @$node, $value;
next if $self->inline =~ /^\s*\]/;
- $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
+ $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
unless $self->{inline} =~ s/^\,\s*//;
}
return $node;
sub _parse_inline_double_quoted {
my $self = shift;
my $node;
- if ($self->inline =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) {
+ # https://rt.cpan.org/Public/Bug/Display.html?id=90593
+ if ($self->inline =~ /^"((?:(?:\\"|[^"]){0,32766}){0,32766})"\s*(.*)$/) {
$node = $1;
$self->inline($2);
$node =~ s/\\"/"/g;
sub _parse_inline_single_quoted {
my $self = shift;
my $node;
- if ($self->inline =~ /^'((?:''|[^'])*)'\s*(.*)$/) {
+ if ($self->inline =~ /^'((?:(?:''|[^']){0,32766}){0,32766})'\s*(.*)$/) {
$node = $1;
$self->inline($2);
$node =~ s/''/'/g;
return $value if $value eq '';
return undef if $value =~ /^~$/;
return $value
- unless $value =~ /^[\@\`\^]/ or
+ unless $value =~ /^[\@\`]/ or
$value =~ /^[\-\?]\s/;
$self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value);
}
# 3) Find the next _content_ line
# A) Skip over any throwaways (Comments/blanks)
# B) Set $self->indent, $self->content, $self->line
-# 4) Expand tabs appropriately
+# 4) Expand tabs appropriately
sub _parse_next_line {
my $self = shift;
my ($type) = @_;
else {
# First get rid of any comments.
while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) {
- $self->lines->[0] =~ /^( *)/ or die;
+ $self->lines->[0] =~ /^( *)/;
last unless length($1) <= $offset;
shift @{$self->lines};
$self->{line}++;
$offset = $self->offset->[++$level];
}
# Determine the offset for a new collection level
- elsif ($type == COLLECTION and
+ elsif ($type == COLLECTION and
$self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
$self->_parse_throwaway_comments();
if ($self->eos) {
return;
}
else {
- $self->lines->[0] =~ /^( *)\S/ or die;
+ $self->lines->[0] =~ /^( *)\S/ or
+ $self->die('YAML_PARSE_ERR_NONSPACE_INDENTATION');
if (length($1) > $offset) {
$self->offset->[$level+1] = length($1);
}
}
$offset = $self->offset->[++$level];
}
-
+
if ($type == LEAF) {
while (@{$self->lines} and
$self->lines->[0] =~ m{^( *)(\#)} and
else {
$self->_parse_throwaway_comments();
}
- return if $self->eos;
-
+ return if $self->eos;
+
if ($self->lines->[0] =~ /^---(\s|$)/) {
$self->done(1);
return;
}
- if ($type == LEAF and
+ if ($type == LEAF and
$self->lines->[0] =~ /^ {$offset}(.*)$/
) {
$self->indent($offset);
while ($self->offset->[$level] > length($1)) {
$level--;
}
- $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
+ $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
if $self->offset->[$level] != length($1);
$self->indent(length($1));
$self->content($2);
#==============================================================================
# Printable characters for escapes
-my %unescapes =
- (
- z => "\x00", a => "\x07", t => "\x09",
- n => "\x0a", v => "\x0b", f => "\x0c",
- r => "\x0d", e => "\x1b", '\\' => '\\',
+my %unescapes = (
+ 0 => "\x00",
+ a => "\x07",
+ t => "\x09",
+ n => "\x0a",
+ 'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted
+ f => "\x0c",
+ r => "\x0d",
+ e => "\x1b",
+ '\\' => '\\',
);
-
+
# Transform all the backslash style escape characters to their literal meaning
sub _unescape {
my $self = shift;
my ($node) = @_;
- $node =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/
+ $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
(length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
return $node;
}
1;
-
-__END__
-
-=head1 NAME
-
-YAML::Loader - YAML class for loading Perl objects to YAML
-
-=head1 SYNOPSIS
-
- use YAML::Loader;
- my $loader = YAML::Loader->new;
- my $hash = $loader->load(<<'...');
- foo: bar
- ...
-
-=head1 DESCRIPTION
-
-YAML::Loader is the module that YAML.pm used to deserialize YAML to Perl
-objects. It is fully object oriented and usable on its own.
-
-=head1 AUTHOR
-
-Ingy döt Net <ingy@cpan.org>
-
-=head1 COPYRIGHT
-
-Copyright (c) 2006. Ingy döt Net. All rights reserved.
-
-This program is free software; you can redistribute it and/or modify it
-under the same terms as Perl itself.
-
-See L<http://www.perl.com/perl/misc/Artistic.html>
-
-=cut
projects / kivitendo-erp.git / blobdiff