X-Git-Url: http://wagnertech.de/git?a=blobdiff_plain;f=modules%2Foverride%2FYAML%2FLoader.pm;h=2cef54e8e6f8ff530a073a11136ee51f59081029;hb=e811dffe90fb1fcdfee55d1ac1a26b7d2399cf44;hp=969867d90e99e5b02d348d3ba6744d1f9adc16ca;hpb=b179b8df8426376f1592c7fdc3e693ed564c2fc3;p=kivitendo-erp.git diff --git a/modules/override/YAML/Loader.pm b/modules/override/YAML/Loader.pm index 969867d90..2cef54e8e 100644 --- a/modules/override/YAML/Loader.pm +++ b/modules/override/YAML/Loader.pm @@ -1,20 +1,22 @@ 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; @@ -30,10 +32,11 @@ sub _parse { $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); @@ -88,7 +91,7 @@ sub _parse { $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'; @@ -111,7 +114,7 @@ sub _parse_node { $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'; @@ -119,7 +122,7 @@ sub _parse_node { $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); } @@ -137,20 +140,20 @@ sub _parse_node { } 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}++; @@ -227,7 +230,7 @@ sub _parse_qualifiers { } 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; @@ -242,25 +245,39 @@ sub _parse_qualifiers { $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'; @@ -315,7 +332,7 @@ sub _parse_mapping { $key = $self->_parse_node(); $key = "$key"; } - # If "default" key (equals sign) + # If "default" key (equals sign) elsif ($self->{content} =~ s/^\=\s*//) { $key = VALUE; } @@ -331,7 +348,7 @@ sub _parse_mapping { $self->content($self->inline); $self->inline(''); } - + unless ($self->{content} =~ s/^:\s*//) { $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT'); } @@ -387,7 +404,7 @@ sub _parse_inline { 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'; @@ -403,7 +420,7 @@ sub _parse_inline { } else { $node = do {my $sv = "*$alias"}; - push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; + push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; } } elsif ($self->inline =~ /^\{/) { @@ -487,7 +504,7 @@ sub _parse_inline_seq { 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; @@ -497,7 +514,8 @@ sub _parse_inline_seq { 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; @@ -513,7 +531,7 @@ sub _parse_inline_double_quoted { 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; @@ -545,7 +563,7 @@ sub _parse_implicit { 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); } @@ -604,7 +622,7 @@ sub _parse_throwaway_comments { # 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) = @_; @@ -629,7 +647,7 @@ sub _parse_next_line { 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}++; @@ -646,7 +664,7 @@ sub _parse_next_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) { @@ -654,7 +672,8 @@ sub _parse_next_line { 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); } @@ -664,7 +683,7 @@ sub _parse_next_line { } $offset = $self->offset->[++$level]; } - + if ($type == LEAF) { while (@{$self->lines} and $self->lines->[0] =~ m{^( *)(\#)} and @@ -678,13 +697,13 @@ sub _parse_next_line { 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); @@ -699,7 +718,7 @@ sub _parse_next_line { 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); @@ -713,54 +732,25 @@ sub _parse_next_line { #============================================================================== # 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 - -=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 - -=cut