diff options
Diffstat (limited to 'lib/YAML')
-rw-r--r-- | lib/YAML/Any.pm | 122 | ||||
-rw-r--r-- | lib/YAML/Any.pod | 165 | ||||
-rw-r--r-- | lib/YAML/Dumper.pm | 575 | ||||
-rw-r--r-- | lib/YAML/Dumper.pod | 38 | ||||
-rw-r--r-- | lib/YAML/Dumper/Base.pm | 111 | ||||
-rw-r--r-- | lib/YAML/Dumper/Base.pod | 35 | ||||
-rw-r--r-- | lib/YAML/Error.pm | 189 | ||||
-rw-r--r-- | lib/YAML/Error.pod | 35 | ||||
-rw-r--r-- | lib/YAML/Loader.pm | 753 | ||||
-rw-r--r-- | lib/YAML/Loader.pod | 39 | ||||
-rw-r--r-- | lib/YAML/Loader/Base.pm | 33 | ||||
-rw-r--r-- | lib/YAML/Loader/Base.pod | 35 | ||||
-rw-r--r-- | lib/YAML/Marshall.pm | 47 | ||||
-rw-r--r-- | lib/YAML/Marshall.pod | 36 | ||||
-rw-r--r-- | lib/YAML/Mo.pm | 80 | ||||
-rw-r--r-- | lib/YAML/Node.pm | 218 | ||||
-rw-r--r-- | lib/YAML/Node.pod | 91 | ||||
-rw-r--r-- | lib/YAML/Tag.pm | 19 | ||||
-rw-r--r-- | lib/YAML/Tag.pod | 34 | ||||
-rw-r--r-- | lib/YAML/Types.pm | 235 | ||||
-rw-r--r-- | lib/YAML/Types.pod | 38 |
21 files changed, 2928 insertions, 0 deletions
diff --git a/lib/YAML/Any.pm b/lib/YAML/Any.pm new file mode 100644 index 0000000..a85461f --- /dev/null +++ b/lib/YAML/Any.pm @@ -0,0 +1,122 @@ +use strict; use warnings; +package YAML::Any; +our $VERSION = '1.15'; + +use Exporter (); + +@YAML::Any::ISA = 'Exporter'; +@YAML::Any::EXPORT = qw(Dump Load); +@YAML::Any::EXPORT_OK = qw(DumpFile LoadFile); + +my @dump_options = qw( + UseCode + DumpCode + SpecVersion + Indent + UseHeader + UseVersion + SortKeys + AnchorPrefix + UseBlock + UseFold + CompressSeries + InlineSeries + UseAliases + Purity + Stringify +); + +my @load_options = qw( + UseCode + LoadCode +); + +my @implementations = qw( + YAML::XS + YAML::Syck + YAML::Old + YAML + YAML::Tiny +); + +sub import { + __PACKAGE__->implementation; + goto &Exporter::import; +} + +sub Dump { + no strict 'refs'; + no warnings 'once'; + my $implementation = __PACKAGE__->implementation; + for my $option (@dump_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::Dump"}(@_); +} + +sub DumpFile { + no strict 'refs'; + no warnings 'once'; + my $implementation = __PACKAGE__->implementation; + for my $option (@dump_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::DumpFile"}(@_); +} + +sub Load { + no strict 'refs'; + no warnings 'once'; + my $implementation = __PACKAGE__->implementation; + for my $option (@load_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::Load"}(@_); +} + +sub LoadFile { + no strict 'refs'; + no warnings 'once'; + my $implementation = __PACKAGE__->implementation; + for my $option (@load_options) { + my $var = "$implementation\::$option"; + my $value = $$var; + local $$var; + $$var = defined $value ? $value : ${"YAML::$option"}; + } + return &{"$implementation\::LoadFile"}(@_); +} + +sub order { + return @YAML::Any::_TEST_ORDER + if @YAML::Any::_TEST_ORDER; + return @implementations; +} + +sub implementation { + my @order = __PACKAGE__->order; + for my $module (@order) { + my $path = $module; + $path =~ s/::/\//g; + $path .= '.pm'; + return $module if exists $INC{$path}; + eval "require $module; 1" and return $module; + } + croak("YAML::Any couldn't find any of these YAML implementations: @order"); +} + +sub croak { + require Carp; + Carp::croak(@_); +} + +1; diff --git a/lib/YAML/Any.pod b/lib/YAML/Any.pod new file mode 100644 index 0000000..d5b821c --- /dev/null +++ b/lib/YAML/Any.pod @@ -0,0 +1,165 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Any - Pick a YAML implementation and use it. + +=head1 STATUS + +WARNING: This module will soon be deprecated. The plan is that YAML.pm itself +will act like an I<Any> module. + +=head1 SYNOPSIS + + use YAML::Any; + $YAML::Indent = 3; + my $yaml = Dump(@objects); + +=head1 DESCRIPTION + +There are several YAML implementations that support the Dump/Load API. This +module selects the best one available and uses it. + +=head1 ORDER + +Currently, YAML::Any will choose the first one of these YAML implementations +that is installed on your system: + +=over + +=item * YAML::XS + +=item * YAML::Syck + +=item * YAML::Old + +=item * YAML + +=item * YAML::Tiny + +=back + +=head1 OPTIONS + +If you specify an option like: + + $YAML::Indent = 4; + +And YAML::Any is using YAML::XS, it will use the proper variable: +$YAML::XS::Indent. + +=head1 SUBROUTINES + +Like all the YAML modules that YAML::Any uses, the following subroutines are +exported by default: + +=over + +=item * Dump + +=item * Load + +=back + +and the following subroutines are exportable by request: + +=over + +=item * DumpFile + +=item * LoadFile + +=back + +=head1 METHODS + +YAML::Any provides the following class methods. + +=over + +=item C<< YAML::Any->order >> + +This method returns a list of the current possible implementations that +YAML::Any will search for. + +=item C<< YAML::Any->implementation >> + +This method returns the implementation the YAML::Any will use. This result is +obtained by finding the first member of YAML::Any->order that is either +already loaded in C<%INC> or that can be loaded using C<require>. If no +implementation is found, an error will be thrown. + +=back + +=head1 EXAMPLES + +=head2 DumpFile and LoadFile + +Here is an example for C<DumpFile>: + + #!/usr/bin/perl + + use strict; + use warnings; + + use YAML::Any qw(DumpFile); + + my $ds = + { + array => [5,6,100], + string => "Hello", + }; + + DumpFile("hello.yml", $ds); + +When run, this creates a file called C<hello.yml> in the current working +directory, with the following contents. + + --- + array: + - 5 + - 6 + - 100 + string: Hello + +In turn, the following C<LoadFile> example, loads the contents from there and +accesses them: + + #!/usr/bin/perl + + use strict; + use warnings; + + use YAML::Any qw(LoadFile); + + my ($ds) = LoadFile("hello.yml"); + + print "String == '", $ds->{string}, "'\n"; + +Assuming C<hello.yml> exists, and is as created by the C<DumpFile> example, +it prints: + + $ perl load.pl + String == 'Hello' + $ + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Dumper.pm b/lib/YAML/Dumper.pm new file mode 100644 index 0000000..5f75ab2 --- /dev/null +++ b/lib/YAML/Dumper.pm @@ -0,0 +1,575 @@ +package YAML::Dumper; + +use YAML::Mo; +extends 'YAML::Dumper::Base'; + +use YAML::Dumper::Base; +use YAML::Node; +use YAML::Types; +use Scalar::Util qw(); + +# Context constants +use constant KEY => 3; +use constant BLESSED => 4; +use constant FROMARRAY => 5; +use constant VALUE => "\x07YAML\x07VALUE\x07"; + +# Common YAML character sets +my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]'; +my $LIT_CHAR = '|'; + +#============================================================================== +# OO version of Dump. YAML->new->dump($foo); +sub dump { + my $self = shift; + $self->stream(''); + $self->document(0); + for my $document (@_) { + $self->{document}++; + $self->transferred({}); + $self->id_refcnt({}); + $self->id_anchor({}); + $self->anchor(1); + $self->level(0); + $self->offset->[0] = 0 - $self->indent_width; + $self->_prewalk($document); + $self->_emit_header($document); + $self->_emit_node($document); + } + return $self->stream; +} + +# Every YAML document in the stream must begin with a YAML header, unless +# there is only a single document and the user requests "no header". +sub _emit_header { + my $self = shift; + my ($node) = @_; + if (not $self->use_header and + $self->document == 1 + ) { + $self->die('YAML_DUMP_ERR_NO_HEADER') + unless ref($node) =~ /^(HASH|ARRAY)$/; + $self->die('YAML_DUMP_ERR_NO_HEADER') + if ref($node) eq 'HASH' and keys(%$node) == 0; + $self->die('YAML_DUMP_ERR_NO_HEADER') + if ref($node) eq 'ARRAY' and @$node == 0; + # XXX Also croak if aliased, blessed, or ynode + $self->headless(1); + return; + } + $self->{stream} .= '---'; +# XXX Consider switching to 1.1 style + if ($self->use_version) { +# $self->{stream} .= " #YAML:1.0"; + } +} + +# Walk the tree to be dumped and keep track of its reference counts. +# This function is where the Dumper does all its work. All type +# transfers happen here. +sub _prewalk { + my $self = shift; + my $stringify = $self->stringify; + my ($class, $type, $node_id) = $self->node_info(\$_[0], $stringify); + + # Handle typeglobs + if ($type eq 'GLOB') { + $self->transferred->{$node_id} = + YAML::Type::glob->yaml_dump($_[0]); + $self->_prewalk($self->transferred->{$node_id}); + return; + } + + # Handle regexps + if (ref($_[0]) eq 'Regexp') { + return; + } + + # Handle Purity for scalars. + # XXX can't find a use case yet. Might be YAGNI. + if (not ref $_[0]) { + $self->{id_refcnt}{$node_id}++ if $self->purity; + return; + } + + # Make a copy of original + my $value = $_[0]; + ($class, $type, $node_id) = $self->node_info($value, $stringify); + + # Must be a stringified object. + return if (ref($value) and not $type); + + # Look for things already transferred. + if ($self->transferred->{$node_id}) { + (undef, undef, $node_id) = (ref $self->transferred->{$node_id}) + ? $self->node_info($self->transferred->{$node_id}, $stringify) + : $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + + # Handle code refs + if ($type eq 'CODE') { + $self->transferred->{$node_id} = 'placeholder'; + YAML::Type::code->yaml_dump( + $self->dump_code, + $_[0], + $self->transferred->{$node_id} + ); + ($class, $type, $node_id) = + $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + + # Handle blessed things + if (defined $class) { + if ($value->can('yaml_dump')) { + $value = $value->yaml_dump; + } + elsif ($type eq 'SCALAR') { + $self->transferred->{$node_id} = 'placeholder'; + YAML::Type::blessed->yaml_dump + ($_[0], $self->transferred->{$node_id}); + ($class, $type, $node_id) = + $self->node_info(\ $self->transferred->{$node_id}, $stringify); + $self->{id_refcnt}{$node_id}++; + return; + } + else { + $value = YAML::Type::blessed->yaml_dump($value); + } + $self->transferred->{$node_id} = $value; + (undef, $type, $node_id) = $self->node_info($value, $stringify); + } + + # Handle YAML Blessed things + require YAML; + if (defined YAML->global_object()->{blessed_map}{$node_id}) { + $value = YAML->global_object()->{blessed_map}{$node_id}; + $self->transferred->{$node_id} = $value; + ($class, $type, $node_id) = $self->node_info($value, $stringify); + $self->_prewalk($value); + return; + } + + # Handle hard refs + if ($type eq 'REF' or $type eq 'SCALAR') { + $value = YAML::Type::ref->yaml_dump($value); + $self->transferred->{$node_id} = $value; + (undef, $type, $node_id) = $self->node_info($value, $stringify); + } + + # Handle ref-to-glob's + elsif ($type eq 'GLOB') { + my $ref_ynode = $self->transferred->{$node_id} = + YAML::Type::ref->yaml_dump($value); + + my $glob_ynode = $ref_ynode->{&VALUE} = + YAML::Type::glob->yaml_dump($$value); + + (undef, undef, $node_id) = $self->node_info($glob_ynode, $stringify); + $self->transferred->{$node_id} = $glob_ynode; + $self->_prewalk($glob_ynode); + return; + } + + # Increment ref count for node + return if ++($self->{id_refcnt}{$node_id}) > 1; + + # Keep on walking + if ($type eq 'HASH') { + $self->_prewalk($value->{$_}) + for keys %{$value}; + return; + } + elsif ($type eq 'ARRAY') { + $self->_prewalk($_) + for @{$value}; + return; + } + + # Unknown type. Need to know about it. + $self->warn(<<"..."); +YAML::Dumper can't handle dumping this type of data. +Please report this to the author. + +id: $node_id +type: $type +class: $class +value: $value + +... + + return; +} + +# Every data element and sub data element is a node. +# Everything emitted goes through this function. +sub _emit_node { + my $self = shift; + my ($type, $node_id); + my $ref = ref($_[0]); + if ($ref) { + if ($ref eq 'Regexp') { + $self->_emit(' !!perl/regexp'); + $self->_emit_str("$_[0]"); + return; + } + (undef, $type, $node_id) = $self->node_info($_[0], $self->stringify); + } + else { + $type = $ref || 'SCALAR'; + (undef, undef, $node_id) = $self->node_info(\$_[0], $self->stringify); + } + + my ($ynode, $tag) = ('') x 2; + my ($value, $context) = (@_, 0); + + if (defined $self->transferred->{$node_id}) { + $value = $self->transferred->{$node_id}; + $ynode = ynode($value); + if (ref $value) { + $tag = defined $ynode ? $ynode->tag->short : ''; + (undef, $type, $node_id) = + $self->node_info($value, $self->stringify); + } + else { + $ynode = ynode($self->transferred->{$node_id}); + $tag = defined $ynode ? $ynode->tag->short : ''; + $type = 'SCALAR'; + (undef, undef, $node_id) = + $self->node_info( + \ $self->transferred->{$node_id}, + $self->stringify + ); + } + } + elsif ($ynode = ynode($value)) { + $tag = $ynode->tag->short; + } + + if ($self->use_aliases) { + $self->{id_refcnt}{$node_id} ||= 0; + if ($self->{id_refcnt}{$node_id} > 1) { + if (defined $self->{id_anchor}{$node_id}) { + $self->{stream} .= ' *' . $self->{id_anchor}{$node_id} . "\n"; + return; + } + my $anchor = $self->anchor_prefix . $self->{anchor}++; + $self->{stream} .= ' &' . $anchor; + $self->{id_anchor}{$node_id} = $anchor; + } + } + + return $self->_emit_str("$value") # Stringified object + if ref($value) and not $type; + return $self->_emit_scalar($value, $tag) + if $type eq 'SCALAR' and $tag; + return $self->_emit_str($value) + if $type eq 'SCALAR'; + return $self->_emit_mapping($value, $tag, $node_id, $context) + if $type eq 'HASH'; + return $self->_emit_sequence($value, $tag) + if $type eq 'ARRAY'; + $self->warn('YAML_DUMP_WARN_BAD_NODE_TYPE', $type); + return $self->_emit_str("$value"); +} + +# A YAML mapping is akin to a Perl hash. +sub _emit_mapping { + my $self = shift; + my ($value, $tag, $node_id, $context) = @_; + $self->{stream} .= " !$tag" if $tag; + + # Sometimes 'keys' fails. Like on a bad tie implementation. + my $empty_hash = not(eval {keys %$value}); + $self->warn('YAML_EMIT_WARN_KEYS', $@) if $@; + return ($self->{stream} .= " {}\n") if $empty_hash; + + # If CompressSeries is on (default) and legal is this context, then + # use it and make the indent level be 2 for this node. + if ($context == FROMARRAY and + $self->compress_series and + not (defined $self->{id_anchor}{$node_id} or $tag or $empty_hash) + ) { + $self->{stream} .= ' '; + $self->offset->[$self->level+1] = $self->offset->[$self->level] + 2; + } + else { + $context = 0; + $self->{stream} .= "\n" + unless $self->headless && not($self->headless(0)); + $self->offset->[$self->level+1] = + $self->offset->[$self->level] + $self->indent_width; + } + + $self->{level}++; + my @keys; + if ($self->sort_keys == 1) { + if (ynode($value)) { + @keys = keys %$value; + } + else { + @keys = sort keys %$value; + } + } + elsif ($self->sort_keys == 2) { + @keys = sort keys %$value; + } + # XXX This is hackish but sometimes handy. Not sure whether to leave it in. + elsif (ref($self->sort_keys) eq 'ARRAY') { + my $i = 1; + my %order = map { ($_, $i++) } @{$self->sort_keys}; + @keys = sort { + (defined $order{$a} and defined $order{$b}) + ? ($order{$a} <=> $order{$b}) + : ($a cmp $b); + } keys %$value; + } + else { + @keys = keys %$value; + } + # Force the YAML::VALUE ('=') key to sort last. + if (exists $value->{&VALUE}) { + for (my $i = 0; $i < @keys; $i++) { + if ($keys[$i] eq &VALUE) { + splice(@keys, $i, 1); + push @keys, &VALUE; + last; + } + } + } + + for my $key (@keys) { + $self->_emit_key($key, $context); + $context = 0; + $self->{stream} .= ':'; + $self->_emit_node($value->{$key}); + } + $self->{level}--; +} + +# A YAML series is akin to a Perl array. +sub _emit_sequence { + my $self = shift; + my ($value, $tag) = @_; + $self->{stream} .= " !$tag" if $tag; + + return ($self->{stream} .= " []\n") if @$value == 0; + + $self->{stream} .= "\n" + unless $self->headless && not($self->headless(0)); + + # XXX Really crufty feature. Better implemented by ynodes. + if ($self->inline_series and + @$value <= $self->inline_series and + not (scalar grep {ref or /\n/} @$value) + ) { + $self->{stream} =~ s/\n\Z/ /; + $self->{stream} .= '['; + for (my $i = 0; $i < @$value; $i++) { + $self->_emit_str($value->[$i], KEY); + last if $i == $#{$value}; + $self->{stream} .= ', '; + } + $self->{stream} .= "]\n"; + return; + } + + $self->offset->[$self->level + 1] = + $self->offset->[$self->level] + $self->indent_width; + $self->{level}++; + for my $val (@$value) { + $self->{stream} .= ' ' x $self->offset->[$self->level]; + $self->{stream} .= '-'; + $self->_emit_node($val, FROMARRAY); + } + $self->{level}--; +} + +# Emit a mapping key +sub _emit_key { + my $self = shift; + my ($value, $context) = @_; + $self->{stream} .= ' ' x $self->offset->[$self->level] + unless $context == FROMARRAY; + $self->_emit_str($value, KEY); +} + +# Emit a blessed SCALAR +sub _emit_scalar { + my $self = shift; + my ($value, $tag) = @_; + $self->{stream} .= " !$tag"; + $self->_emit_str($value, BLESSED); +} + +sub _emit { + my $self = shift; + $self->{stream} .= join '', @_; +} + +# Emit a string value. YAML has many scalar styles. This routine attempts to +# guess the best style for the text. +sub _emit_str { + my $self = shift; + my $type = $_[1] || 0; + + # Use heuristics to find the best scalar emission style. + $self->offset->[$self->level + 1] = + $self->offset->[$self->level] + $self->indent_width; + $self->{level}++; + + my $sf = $type == KEY ? '' : ' '; + my $sb = $type == KEY ? '? ' : ' '; + my $ef = $type == KEY ? '' : "\n"; + my $eb = "\n"; + + while (1) { + $self->_emit($sf), + $self->_emit_plain($_[0]), + $self->_emit($ef), last + if not defined $_[0]; + $self->_emit($sf, '=', $ef), last + if $_[0] eq VALUE; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] =~ /$ESCAPE_CHAR/; + if ($_[0] =~ /\n/) { + $self->_emit($sb), + $self->_emit_block($LIT_CHAR, $_[0]), + $self->_emit($eb), last + if $self->use_block; + Carp::cluck "[YAML] \$UseFold is no longer supported" + if $self->use_fold; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if length $_[0] <= 30; + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] !~ /\n\s*\S/; + $self->_emit($sb), + $self->_emit_block($LIT_CHAR, $_[0]), + $self->_emit($eb), last; + } + $self->_emit($sf), + $self->_emit_number($_[0]), + $self->_emit($ef), last + if $self->is_literal_number($_[0]); + $self->_emit($sf), + $self->_emit_plain($_[0]), + $self->_emit($ef), last + if $self->is_valid_plain($_[0]); + $self->_emit($sf), + $self->_emit_double($_[0]), + $self->_emit($ef), last + if $_[0] =~ /'/; + $self->_emit($sf), + $self->_emit_single($_[0]), + $self->_emit($ef); + last; + } + + $self->{level}--; + + return; +} + +sub is_literal_number { + my $self = shift; + # Stolen from JSON::Tiny + return B::svref_2object(\$_[0])->FLAGS & (B::SVp_IOK | B::SVp_NOK) + && 0 + $_[0] eq $_[0]; +} + +sub _emit_number { + my $self = shift; + return $self->_emit_plain($_[0]); +} + +# Check whether or not a scalar should be emitted as an plain scalar. +sub is_valid_plain { + my $self = shift; + return 0 unless length $_[0]; + return 0 if $self->quote_numeric_strings and Scalar::Util::looks_like_number($_[0]); + # refer to YAML::Loader::parse_inline_simple() + return 0 if $_[0] =~ /^[\s\{\[\~\`\'\"\!\@\#\>\|\%\&\?\*\^]/; + return 0 if $_[0] =~ /[\{\[\]\},]/; + return 0 if $_[0] =~ /[:\-\?]\s/; + return 0 if $_[0] =~ /\s#/; + return 0 if $_[0] =~ /\:(\s|$)/; + return 0 if $_[0] =~ /[\s\|\>]$/; + return 0 if $_[0] eq '-'; + return 1; +} + +sub _emit_block { + my $self = shift; + my ($indicator, $value) = @_; + $self->{stream} .= $indicator; + $value =~ /(\n*)\Z/; + my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-'; + $value = '~' if not defined $value; + $self->{stream} .= $chomp; + $self->{stream} .= $self->indent_width if $value =~ /^\s/; + $self->{stream} .= $self->indent($value); +} + +# Plain means that the scalar is unquoted. +sub _emit_plain { + my $self = shift; + $self->{stream} .= defined $_[0] ? $_[0] : '~'; +} + +# Double quoting is for single lined escaped strings. +sub _emit_double { + my $self = shift; + (my $escaped = $self->escape($_[0])) =~ s/"/\\"/g; + $self->{stream} .= qq{"$escaped"}; +} + +# Single quoting is for single lined unescaped strings. +sub _emit_single { + my $self = shift; + my $item = shift; + $item =~ s{'}{''}g; + $self->{stream} .= "'$item'"; +} + +#============================================================================== +# Utility subroutines. +#============================================================================== + +# Indent a scalar to the current indentation level. +sub indent { + my $self = shift; + my ($text) = @_; + return $text unless length $text; + $text =~ s/\n\Z//; + my $indent = ' ' x $self->offset->[$self->level]; + $text =~ s/^/$indent/gm; + $text = "\n$text"; + return $text; +} + +# Escapes for unprintable characters +my @escapes = qw(\0 \x01 \x02 \x03 \x04 \x05 \x06 \a + \x08 \t \n \v \f \r \x0e \x0f + \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17 + \x18 \x19 \x1a \e \x1c \x1d \x1e \x1f + ); + +# Escape the unprintable characters +sub escape { + my $self = shift; + my ($text) = @_; + $text =~ s/\\/\\\\/g; + $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge; + return $text; +} + +1; diff --git a/lib/YAML/Dumper.pod b/lib/YAML/Dumper.pod new file mode 100644 index 0000000..7646fbb --- /dev/null +++ b/lib/YAML/Dumper.pod @@ -0,0 +1,38 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Dumper - YAML class for dumping Perl objects to YAML + +=head1 SYNOPSIS + + use YAML::Dumper; + my $dumper = YAML::Dumper->new; + $dumper->indent_width(4); + print $dumper->dump({foo => 'bar'}); + +=head1 DESCRIPTION + +YAML::Dumper is the module that YAML.pm used to serialize Perl objects to +YAML. It is fully object oriented and usable on its own. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Dumper/Base.pm b/lib/YAML/Dumper/Base.pm new file mode 100644 index 0000000..23db7b1 --- /dev/null +++ b/lib/YAML/Dumper/Base.pm @@ -0,0 +1,111 @@ +package YAML::Dumper::Base; + +use YAML::Mo; + +use YAML::Node; + +# YAML Dumping options +has spec_version => default => sub {'1.0'}; +has indent_width => default => sub {2}; +has use_header => default => sub {1}; +has use_version => default => sub {0}; +has sort_keys => default => sub {1}; +has anchor_prefix => default => sub {''}; +has dump_code => default => sub {0}; +has use_block => default => sub {0}; +has use_fold => default => sub {0}; +has compress_series => default => sub {1}; +has inline_series => default => sub {0}; +has use_aliases => default => sub {1}; +has purity => default => sub {0}; +has stringify => default => sub {0}; +has quote_numeric_strings => default => sub {0}; + +# Properties +has stream => default => sub {''}; +has document => default => sub {0}; +has transferred => default => sub {{}}; +has id_refcnt => default => sub {{}}; +has id_anchor => default => sub {{}}; +has anchor => default => sub {1}; +has level => default => sub {0}; +has offset => default => sub {[]}; +has headless => default => sub {0}; +has blessed_map => default => sub {{}}; + +# Global Options are an idea taken from Data::Dumper. Really they are just +# sugar on top of real OO properties. They make the simple Dump/Load API +# easy to configure. +sub set_global_options { + my $self = shift; + $self->spec_version($YAML::SpecVersion) + if defined $YAML::SpecVersion; + $self->indent_width($YAML::Indent) + if defined $YAML::Indent; + $self->use_header($YAML::UseHeader) + if defined $YAML::UseHeader; + $self->use_version($YAML::UseVersion) + if defined $YAML::UseVersion; + $self->sort_keys($YAML::SortKeys) + if defined $YAML::SortKeys; + $self->anchor_prefix($YAML::AnchorPrefix) + if defined $YAML::AnchorPrefix; + $self->dump_code($YAML::DumpCode || $YAML::UseCode) + if defined $YAML::DumpCode or defined $YAML::UseCode; + $self->use_block($YAML::UseBlock) + if defined $YAML::UseBlock; + $self->use_fold($YAML::UseFold) + if defined $YAML::UseFold; + $self->compress_series($YAML::CompressSeries) + if defined $YAML::CompressSeries; + $self->inline_series($YAML::InlineSeries) + if defined $YAML::InlineSeries; + $self->use_aliases($YAML::UseAliases) + if defined $YAML::UseAliases; + $self->purity($YAML::Purity) + if defined $YAML::Purity; + $self->stringify($YAML::Stringify) + if defined $YAML::Stringify; + $self->quote_numeric_strings($YAML::QuoteNumericStrings) + if defined $YAML::QuoteNumericStrings; +} + +sub dump { + my $self = shift; + $self->die('dump() not implemented in this class.'); +} + +sub blessed { + my $self = shift; + my ($ref) = @_; + $ref = \$_[0] unless ref $ref; + my (undef, undef, $node_id) = YAML::Mo::Object->node_info($ref); + $self->{blessed_map}->{$node_id}; +} + +sub bless { + my $self = shift; + my ($ref, $blessing) = @_; + my $ynode; + $ref = \$_[0] unless ref $ref; + my (undef, undef, $node_id) = YAML::Mo::Object->node_info($ref); + if (not defined $blessing) { + $ynode = YAML::Node->new($ref); + } + elsif (ref $blessing) { + $self->die() unless ynode($blessing); + $ynode = $blessing; + } + else { + no strict 'refs'; + my $transfer = $blessing . "::yaml_dump"; + $self->die() unless defined &{$transfer}; + $ynode = &{$transfer}($ref); + $self->die() unless ynode($ynode); + } + $self->{blessed_map}->{$node_id} = $ynode; + my $object = ynode($ynode) or $self->die(); + return $object; +} + +1; diff --git a/lib/YAML/Dumper/Base.pod b/lib/YAML/Dumper/Base.pod new file mode 100644 index 0000000..f32e404 --- /dev/null +++ b/lib/YAML/Dumper/Base.pod @@ -0,0 +1,35 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Dumper::Base - Base class for YAML Dumper classes + +=head1 SYNOPSIS + + package YAML::Dumper::Something; + use YAML::Dumper::Base -base; + +=head1 DESCRIPTION + +YAML::Dumper::Base is a base class for creating YAML dumper classes. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Error.pm b/lib/YAML/Error.pm new file mode 100644 index 0000000..7725ba3 --- /dev/null +++ b/lib/YAML/Error.pm @@ -0,0 +1,189 @@ +package YAML::Error; + +use YAML::Mo; + +has 'code'; +has 'type' => default => sub {'Error'}; +has 'line'; +has 'document'; +has 'arguments' => default => sub {[]}; + +my ($error_messages, %line_adjust); + +sub format_message { + my $self = shift; + my $output = 'YAML ' . $self->type . ': '; + my $code = $self->code; + if ($error_messages->{$code}) { + $code = sprintf($error_messages->{$code}, @{$self->arguments}); + } + $output .= $code . "\n"; + + $output .= ' Code: ' . $self->code . "\n" + if defined $self->code; + $output .= ' Line: ' . $self->line . "\n" + if defined $self->line; + $output .= ' Document: ' . $self->document . "\n" + if defined $self->document; + return $output; +} + +sub error_messages { + $error_messages; +} + +%$error_messages = map {s/^\s+//;$_} split "\n", <<'...'; +YAML_PARSE_ERR_BAD_CHARS + Invalid characters in stream. This parser only supports printable ASCII +YAML_PARSE_ERR_BAD_MAJOR_VERSION + Can't parse a %s document with a 1.0 parser +YAML_PARSE_WARN_BAD_MINOR_VERSION + Parsing a %s document with a 1.0 parser +YAML_PARSE_WARN_MULTIPLE_DIRECTIVES + '%s directive used more than once' +YAML_PARSE_ERR_TEXT_AFTER_INDICATOR + No text allowed after indicator +YAML_PARSE_ERR_NO_ANCHOR + No anchor for alias '*%s' +YAML_PARSE_ERR_NO_SEPARATOR + Expected separator '---' +YAML_PARSE_ERR_SINGLE_LINE + Couldn't parse single line value +YAML_PARSE_ERR_BAD_ANCHOR + Invalid anchor +YAML_DUMP_ERR_INVALID_INDENT + Invalid Indent width specified: '%s' +YAML_LOAD_USAGE + usage: YAML::Load($yaml_stream_scalar) +YAML_PARSE_ERR_BAD_NODE + Can't parse node +YAML_PARSE_ERR_BAD_EXPLICIT + Unsupported explicit transfer: '%s' +YAML_DUMP_USAGE_DUMPCODE + Invalid value for DumpCode: '%s' +YAML_LOAD_ERR_FILE_INPUT + Couldn't open %s for input:\n%s +YAML_DUMP_ERR_FILE_CONCATENATE + Can't concatenate to YAML file %s +YAML_DUMP_ERR_FILE_OUTPUT + Couldn't open %s for output:\n%s +YAML_DUMP_ERR_NO_HEADER + With UseHeader=0, the node must be a plain hash or array +YAML_DUMP_WARN_BAD_NODE_TYPE + Can't perform serialization for node type: '%s' +YAML_EMIT_WARN_KEYS + Encountered a problem with 'keys':\n%s +YAML_DUMP_WARN_DEPARSE_FAILED + Deparse failed for CODE reference +YAML_DUMP_WARN_CODE_DUMMY + Emitting dummy subroutine for CODE reference +YAML_PARSE_ERR_MANY_EXPLICIT + More than one explicit transfer +YAML_PARSE_ERR_MANY_IMPLICIT + More than one implicit request +YAML_PARSE_ERR_MANY_ANCHOR + More than one anchor +YAML_PARSE_ERR_ANCHOR_ALIAS + Can't define both an anchor and an alias +YAML_PARSE_ERR_BAD_ALIAS + Invalid alias +YAML_PARSE_ERR_MANY_ALIAS + More than one alias +YAML_LOAD_ERR_NO_CONVERT + Can't convert implicit '%s' node to explicit '%s' node +YAML_LOAD_ERR_NO_DEFAULT_VALUE + No default value for '%s' explicit transfer +YAML_LOAD_ERR_NON_EMPTY_STRING + Only the empty string can be converted to a '%s' +YAML_LOAD_ERR_BAD_MAP_TO_SEQ + Can't transfer map as sequence. Non numeric key '%s' encountered. +YAML_DUMP_ERR_BAD_GLOB + '%s' is an invalid value for Perl glob +YAML_DUMP_ERR_BAD_REGEXP + '%s' is an invalid value for Perl Regexp +YAML_LOAD_ERR_BAD_MAP_ELEMENT + Invalid element in map +YAML_LOAD_WARN_DUPLICATE_KEY + Duplicate map key found. Ignoring. +YAML_LOAD_ERR_BAD_SEQ_ELEMENT + Invalid element in sequence +YAML_PARSE_ERR_INLINE_MAP + Can't parse inline map +YAML_PARSE_ERR_INLINE_SEQUENCE + Can't parse inline sequence +YAML_PARSE_ERR_BAD_DOUBLE + Can't parse double quoted string +YAML_PARSE_ERR_BAD_SINGLE + Can't parse single quoted string +YAML_PARSE_ERR_BAD_INLINE_IMPLICIT + Can't parse inline implicit value '%s' +YAML_PARSE_ERR_BAD_IMPLICIT + Unrecognized implicit value '%s' +YAML_PARSE_ERR_INDENTATION + Error. Invalid indentation level +YAML_PARSE_ERR_INCONSISTENT_INDENTATION + Inconsistent indentation level +YAML_LOAD_WARN_UNRESOLVED_ALIAS + Can't resolve alias *%s +YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP + No 'REGEXP' element for Perl regexp +YAML_LOAD_WARN_BAD_REGEXP_ELEM + Unknown element '%s' in Perl regexp +YAML_LOAD_WARN_GLOB_NAME + No 'NAME' element for Perl glob +YAML_LOAD_WARN_PARSE_CODE + Couldn't parse Perl code scalar: %s +YAML_LOAD_WARN_CODE_DEPARSE + Won't parse Perl code unless $YAML::LoadCode is set +YAML_EMIT_ERR_BAD_LEVEL + Internal Error: Bad level detected +YAML_PARSE_WARN_AMBIGUOUS_TAB + Amibiguous tab converted to spaces +YAML_LOAD_WARN_BAD_GLOB_ELEM + Unknown element '%s' in Perl glob +YAML_PARSE_ERR_ZERO_INDENT + Can't use zero as an indentation width +YAML_LOAD_WARN_GLOB_IO + Can't load an IO filehandle. Yet!!! +... + +%line_adjust = map {($_, 1)} + qw(YAML_PARSE_ERR_BAD_MAJOR_VERSION + YAML_PARSE_WARN_BAD_MINOR_VERSION + YAML_PARSE_ERR_TEXT_AFTER_INDICATOR + YAML_PARSE_ERR_NO_ANCHOR + YAML_PARSE_ERR_MANY_EXPLICIT + YAML_PARSE_ERR_MANY_IMPLICIT + YAML_PARSE_ERR_MANY_ANCHOR + YAML_PARSE_ERR_ANCHOR_ALIAS + YAML_PARSE_ERR_BAD_ALIAS + YAML_PARSE_ERR_MANY_ALIAS + YAML_LOAD_ERR_NO_CONVERT + YAML_LOAD_ERR_NO_DEFAULT_VALUE + YAML_LOAD_ERR_NON_EMPTY_STRING + YAML_LOAD_ERR_BAD_MAP_TO_SEQ + YAML_LOAD_ERR_BAD_STR_TO_INT + YAML_LOAD_ERR_BAD_STR_TO_DATE + YAML_LOAD_ERR_BAD_STR_TO_TIME + YAML_LOAD_WARN_DUPLICATE_KEY + YAML_PARSE_ERR_INLINE_MAP + YAML_PARSE_ERR_INLINE_SEQUENCE + YAML_PARSE_ERR_BAD_DOUBLE + YAML_PARSE_ERR_BAD_SINGLE + YAML_PARSE_ERR_BAD_INLINE_IMPLICIT + YAML_PARSE_ERR_BAD_IMPLICIT + YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP + YAML_LOAD_WARN_BAD_REGEXP_ELEM + YAML_LOAD_WARN_REGEXP_CREATE + YAML_LOAD_WARN_GLOB_NAME + YAML_LOAD_WARN_PARSE_CODE + YAML_LOAD_WARN_CODE_DEPARSE + YAML_LOAD_WARN_BAD_GLOB_ELEM + YAML_PARSE_ERR_ZERO_INDENT + ); + +package YAML::Warning; + +our @ISA = 'YAML::Error'; + +1; diff --git a/lib/YAML/Error.pod b/lib/YAML/Error.pod new file mode 100644 index 0000000..83ff8cf --- /dev/null +++ b/lib/YAML/Error.pod @@ -0,0 +1,35 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Error - Error formatting class for YAML modules + +=head1 SYNOPSIS + + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias); + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + +=head1 DESCRIPTION + +This module provides a C<die> and a C<warn> facility. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Loader.pm b/lib/YAML/Loader.pm new file mode 100644 index 0000000..a724102 --- /dev/null +++ b/lib/YAML/Loader.pm @@ -0,0 +1,753 @@ +package YAML::Loader; + +use YAML::Mo; +extends 'YAML::Loader::Base'; + +use YAML::Loader::Base; +use YAML::Types; + +# Context constants +use constant LEAF => 1; +use constant COLLECTION => 2; +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"; + +sub load { + my $self = shift; + $self->stream($_[0] || ''); + return $self->_parse(); +} + +# Top level function for parsing. Parse each document in order and +# handle processing for YAML headers. +sub _parse { + my $self = shift; + my (%directives, $preface); + $self->{stream} =~ s|\015\012|\012|g; + $self->{stream} =~ s|\015|\012|g; + $self->line(0); + $self->die('YAML_PARSE_ERR_BAD_CHARS') + if $self->stream =~ /$ESCAPE_CHAR/; + $self->{stream} =~ s/(.)\n\Z/$1/s; + $self->lines([split /\x0a/, $self->stream, -1]); + $self->line(1); + # Throw away any comments or blanks before the header (or start of + # content for headerless streams) + $self->_parse_throwaway_comments(); + $self->document(0); + $self->documents([]); + # Add an "assumed" header if there is no header and the stream is + # not empty (after initial throwaways). + if (not $self->eos) { + if ($self->lines->[0] !~ /^---(\s|$)/) { + unshift @{$self->lines}, '---'; + $self->{line}--; + } + } + + # Main Loop. Parse out all the top level nodes and return them. + while (not $self->eos) { + $self->anchor2node({}); + $self->{document}++; + $self->done(0); + $self->level(0); + $self->offset->[0] = -1; + + if ($self->lines->[0] =~ /^---\s*(.*)$/) { + my @words = split /\s+/, $1; + %directives = (); + while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) { + my ($key, $value) = ($1, $2); + shift(@words); + if (defined $directives{$key}) { + $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES', + $key, $self->document); + next; + } + $directives{$key} = $value; + } + $self->preface(join ' ', @words); + } + else { + $self->die('YAML_PARSE_ERR_NO_SEPARATOR'); + } + + if (not $self->done) { + $self->_parse_next_line(COLLECTION); + } + if ($self->done) { + $self->{indent} = -1; + $self->content(''); + } + + $directives{YAML} ||= '1.0'; + $directives{TAB} ||= 'NONE'; + ($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->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML}) + if $self->minor_version ne '0'; + $self->die('Unrecognized TAB policy') + unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/; + + push @{$self->documents}, $self->_parse_node(); + } + return wantarray ? @{$self->documents} : $self->documents->[-1]; +} + +# This function is the dispatcher for parsing each node. Every node +# recurses back through here. (Inlines are an exception as they have +# their own sub-parser.) +sub _parse_node { + my $self = shift; + my $preface = $self->preface; + $self->preface(''); + my ($node, $type, $indicator, $escape, $chomp) = ('') x 5; + my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5; + ($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*//) { + $indicator = $1; + $chomp = $2 if defined($2); + } + else { + $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator; + $self->inline($preface); + $preface = ''; + } + } + if ($alias) { + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) + unless defined $self->anchor2node->{$alias}; + if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { + $node = $self->anchor2node->{$alias}; + } + else { + $node = do {my $sv = "*$alias"}; + 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'); + } + } + elsif ($indicator eq $LIT_CHAR) { + $self->{level}++; + $node = $self->_parse_block($chomp); + $node = $self->_parse_implicit($node) if $implicit; + $self->{level}--; + } + elsif ($indicator eq $FOLD_CHAR) { + $self->{level}++; + $node = $self->_parse_unfold($chomp); + $node = $self->_parse_implicit($node) if $implicit; + $self->{level}--; + } + else { + $self->{level}++; + $self->offset->[$self->level] ||= 0; + if ($self->indent == $self->offset->[$self->level]) { + if ($self->content =~ /^-( |$)/) { + $node = $self->_parse_seq($anchor); + } + elsif ($self->content =~ /(^\?|\:( |$))/) { + $node = $self->_parse_mapping($anchor); + } + elsif ($preface =~ /^\s*$/) { + $node = $self->_parse_implicit(''); + } + else { + $self->die('YAML_PARSE_ERR_BAD_NODE'); + } + } + else { + $node = undef; + } + $self->{level}--; + } + $#{$self->offset} = $self->level; + + if ($explicit) { + if ($class) { + if (not ref $node) { + my $copy = $node; + undef $node; + $node = \$copy; + } + CORE::bless $node, $class; + } + else { + $node = $self->_parse_explicit($node, $explicit); + } + } + if ($anchor) { + if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { + # XXX Can't remember what this code actually does + for my $ref (@{$self->anchor2node->{$anchor}}) { + ${$ref->[0]} = $node; + $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', + $anchor, $ref->[1]); + } + } + $self->anchor2node->{$anchor} = $node; + } + return $node; +} + +# Preprocess the qualifiers that may be attached to any node. +sub _parse_qualifiers { + my $self = shift; + my ($preface) = @_; + my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5; + $self->inline(''); + while ($preface =~ /^[&*!]/) { + my $line = $self->line - 1; + if ($preface =~ s/^\!(\S+)\s*//) { + $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit; + $explicit = $1; + } + elsif ($preface =~ s/^\!\s*//) { + $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit; + $implicit = 1; + } + elsif ($preface =~ s/^\&([^ ,:]+)\s*//) { + $token = $1; + $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; + $anchor = $token; + } + elsif ($preface =~ s/^\*([^ ,:]+)\s*//) { + $token = $1; + $self->die('YAML_PARSE_ERR_BAD_ALIAS') + unless $token =~ /^[a-zA-Z0-9]+$/; + $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias; + $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor; + $alias = $token; + } + } + return ($anchor, $alias, $explicit, $implicit, $preface); +} + +# 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|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) { + ($type, $class) = (($1 || ''), ($2 || '')); + + # 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; + } + + 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 =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) { + ($type, $class) = (($1 || ''), ($2 || '')); + my $type_class = "YAML::Type::$type"; + no strict 'refs'; + if ($type_class->can('yaml_load')) { + return $type_class->yaml_load($node, $class, $self); + } + else { + $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit); + } + } + # This !perl/@Foo and !perl/$Foo are deprecated but still parsed + elsif ($YAML::TagClass->{$explicit} || + $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$} + ) { + $class = $YAML::TagClass->{$explicit} || $2; + if ($class->can('yaml_load')) { + require YAML::Node; + return $class->yaml_load(YAML::Node->new($node, $explicit)); + } + else { + if (ref $node) { + return CORE::bless $node, $class; + } + else { + return CORE::bless \$node, $class; + } + } + } + elsif (ref $node) { + require YAML::Node; + return YAML::Node->new($node, $explicit); + } + else { + # XXX This is likely wrong. Failing test: + # --- !unknown 'scalar value' + return $node; + } +} + +# Parse a YAML mapping into a Perl hash +sub _parse_mapping { + my $self = shift; + my ($anchor) = @_; + my $mapping = {}; + $self->anchor2node->{$anchor} = $mapping; + my $key; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + # If structured key: + if ($self->{content} =~ s/^\?\s*//) { + $self->preface($self->content); + $self->_parse_next_line(COLLECTION); + $key = $self->_parse_node(); + $key = "$key"; + } + # If "default" key (equals sign) + elsif ($self->{content} =~ s/^\=\s*//) { + $key = VALUE; + } + # If "comment" key (slash slash) + elsif ($self->{content} =~ s/^\=\s*//) { + $key = COMMENT; + } + # Regular scalar key: + else { + $self->inline($self->content); + $key = $self->_parse_inline(); + $key = "$key"; + $self->content($self->inline); + $self->inline(''); + } + + unless ($self->{content} =~ s/^:\s*//) { + $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT'); + } + $self->preface($self->content); + my $line = $self->line; + $self->_parse_next_line(COLLECTION); + my $value = $self->_parse_node(); + if (exists $mapping->{$key}) { + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + } + else { + $mapping->{$key} = $value; + } + } + return $mapping; +} + +# Parse a YAML sequence into a Perl array +sub _parse_seq { + my $self = shift; + my ($anchor) = @_; + my $seq = []; + $self->anchor2node->{$anchor} = $seq; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + if ($self->content =~ /^-(?: (.*))?$/) { + $self->preface(defined($1) ? $1 : ''); + } + else { + $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT'); + } + if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) { + $self->indent($self->offset->[$self->level] + 2 + length($1)); + $self->content($2); + $self->level($self->level + 1); + $self->offset->[$self->level] = $self->indent; + $self->preface(''); + push @$seq, $self->_parse_mapping(''); + $self->{level}--; + $#{$self->offset} = $self->level; + } + else { + $self->_parse_next_line(COLLECTION); + push @$seq, $self->_parse_node(); + } + } + return $seq; +} + +# Parse an inline value. Since YAML supports inline collections, this is +# the top level of a sub parsing. +sub _parse_inline { + my $self = shift; + 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}) = + $self->_parse_qualifiers($self->inline); + if ($anchor) { + $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node'; + } + $implicit ||= $top_implicit; + $explicit ||= $top_explicit; + ($top_implicit, $top_explicit) = ('', ''); + if ($alias) { + $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias) + unless defined $self->anchor2node->{$alias}; + if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') { + $node = $self->anchor2node->{$alias}; + } + else { + $node = do {my $sv = "*$alias"}; + push @{$self->anchor2node->{$alias}}, [\$node, $self->line]; + } + } + elsif ($self->inline =~ /^\{/) { + $node = $self->_parse_inline_mapping($anchor); + } + elsif ($self->inline =~ /^\[/) { + $node = $self->_parse_inline_seq($anchor); + } + elsif ($self->inline =~ /^"/) { + $node = $self->_parse_inline_double_quoted(); + $node = $self->_unescape($node); + $node = $self->_parse_implicit($node) if $implicit; + } + elsif ($self->inline =~ /^'/) { + $node = $self->_parse_inline_single_quoted(); + $node = $self->_parse_implicit($node) if $implicit; + } + else { + if ($top) { + $node = $self->inline; + $self->inline(''); + } + else { + $node = $self->_parse_inline_simple(); + } + $node = $self->_parse_implicit($node) unless $explicit; + } + if ($explicit) { + $node = $self->_parse_explicit($node, $explicit); + } + if ($anchor) { + if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') { + for my $ref (@{$self->anchor2node->{$anchor}}) { + ${$ref->[0]} = $node; + $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS', + $anchor, $ref->[1]); + } + } + $self->anchor2node->{$anchor} = $node; + } + return $node; +} + +# Parse the inline YAML mapping into a Perl hash +sub _parse_inline_mapping { + my $self = shift; + my ($anchor) = @_; + my $node = {}; + $self->anchor2node->{$anchor} = $node; + + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\{\s*//; + while (not $self->{inline} =~ s/^\s*\}//) { + my $key = $self->_parse_inline(); + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\: \s*//; + my $value = $self->_parse_inline(); + if (exists $node->{$key}) { + $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY'); + } + else { + $node->{$key} = $value; + } + next if $self->inline =~ /^\s*\}/; + $self->die('YAML_PARSE_ERR_INLINE_MAP') + unless $self->{inline} =~ s/^\,\s*//; + } + return $node; +} + +# Parse the inline YAML sequence into a Perl array +sub _parse_inline_seq { + my $self = shift; + my ($anchor) = @_; + my $node = []; + $self->anchor2node->{$anchor} = $node; + + $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') + unless $self->{inline} =~ s/^\[\s*//; + while (not $self->{inline} =~ s/^\s*\]//) { + my $value = $self->_parse_inline(); + push @$node, $value; + next if $self->inline =~ /^\s*\]/; + $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE') + unless $self->{inline} =~ s/^\,\s*//; + } + return $node; +} + +# Parse the inline double quoted string. +sub _parse_inline_double_quoted { + my $self = shift; + my $node; + # 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; + } + else { + $self->die('YAML_PARSE_ERR_BAD_DOUBLE'); + } + return $node; +} + + +# Parse the inline single quoted string. +sub _parse_inline_single_quoted { + my $self = shift; + my $node; + if ($self->inline =~ /^'((?:(?:''|[^']){0,32766}){0,32766})'\s*(.*)$/) { + $node = $1; + $self->inline($2); + $node =~ s/''/'/g; + } + else { + $self->die('YAML_PARSE_ERR_BAD_SINGLE'); + } + return $node; +} + +# Parse the inline unquoted string and do implicit typing. +sub _parse_inline_simple { + my $self = shift; + my $value; + if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) { + $value = $1; + substr($self->{inline}, 0, length($1)) = ''; + } + else { + $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value); + } + return $value; +} + +sub _parse_implicit { + my $self = shift; + my ($value) = @_; + $value =~ s/\s*$//; + return $value if $value eq ''; + return undef if $value =~ /^~$/; + return $value + unless $value =~ /^[\@\`]/ or + $value =~ /^[\-\?]\s/; + $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value); +} + +# Unfold a YAML multiline scalar into a single string. +sub _parse_unfold { + my $self = shift; + my ($chomp) = @_; + my $node = ''; + my $space = 0; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + $node .= $self->content. "\n"; + $self->_parse_next_line(LEAF); + } + $node =~ s/^(\S.*)\n(?=\S)/$1 /gm; + $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm; + $node =~ s/\n*\Z// unless $chomp eq '+'; + $node .= "\n" unless $chomp; + return $node; +} + +# Parse a YAML block style scalar. This is like a Perl here-document. +sub _parse_block { + my $self = shift; + my ($chomp) = @_; + my $node = ''; + while (not $self->done and $self->indent == $self->offset->[$self->level]) { + $node .= $self->content . "\n"; + $self->_parse_next_line(LEAF); + } + return $node if '+' eq $chomp; + $node =~ s/\n*\Z/\n/; + $node =~ s/\n\Z// if $chomp eq '-'; + return $node; +} + +# Handle Perl style '#' comments. Comments must be at the same indentation +# level as the collection line following them. +sub _parse_throwaway_comments { + my $self = shift; + while (@{$self->lines} and + $self->lines->[0] =~ m{^\s*(\#|$)} + ) { + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); +} + +# This is the routine that controls what line is being parsed. It gets called +# once for each line in the YAML stream. +# +# This routine must: +# 1) Skip past the current line +# 2) Determine the indentation offset for a new level +# 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 +sub _parse_next_line { + my $self = shift; + my ($type) = @_; + my $level = $self->level; + my $offset = $self->offset->[$level]; + $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset; + shift @{$self->lines}; + $self->eos($self->{done} = not @{$self->lines}); + return if $self->eos; + $self->{line}++; + + # Determine the offset for a new leaf node + if ($self->preface =~ + qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/ + ) { + $self->die('YAML_PARSE_ERR_ZERO_INDENT') + if length($1) and $1 == 0; + $type = LEAF; + if (length($1)) { + $self->offset->[$level + 1] = $offset + $1; + } + else { + # First get rid of any comments. + while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) { + $self->lines->[0] =~ /^( *)/; + last unless length($1) <= $offset; + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); + return if $self->eos; + if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) { + $self->offset->[$level+1] = length($1); + } + else { + $self->offset->[$level+1] = $offset + 1; + } + } + $offset = $self->offset->[++$level]; + } + # Determine the offset for a new collection level + elsif ($type == COLLECTION and + $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) { + $self->_parse_throwaway_comments(); + if ($self->eos) { + $self->offset->[$level+1] = $offset + 1; + return; + } + else { + $self->lines->[0] =~ /^( *)\S/ or + $self->die('YAML_PARSE_ERR_NONSPACE_INDENTATION'); + if (length($1) > $offset) { + $self->offset->[$level+1] = length($1); + } + else { + $self->offset->[$level+1] = $offset + 1; + } + } + $offset = $self->offset->[++$level]; + } + + if ($type == LEAF) { + while (@{$self->lines} and + $self->lines->[0] =~ m{^( *)(\#)} and + length($1) < $offset + ) { + shift @{$self->lines}; + $self->{line}++; + } + $self->eos($self->{done} = not @{$self->lines}); + } + else { + $self->_parse_throwaway_comments(); + } + return if $self->eos; + + if ($self->lines->[0] =~ /^---(\s|$)/) { + $self->done(1); + return; + } + if ($type == LEAF and + $self->lines->[0] =~ /^ {$offset}(.*)$/ + ) { + $self->indent($offset); + $self->content($1); + } + elsif ($self->lines->[0] =~ /^\s*$/) { + $self->indent($offset); + $self->content(''); + } + else { + $self->lines->[0] =~ /^( *)(\S.*)$/; + while ($self->offset->[$level] > length($1)) { + $level--; + } + $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION') + if $self->offset->[$level] != length($1); + $self->indent(length($1)); + $self->content($2); + } + $self->die('YAML_PARSE_ERR_INDENTATION') + if $self->indent - $offset > 1; +} + +#============================================================================== +# Utility subroutines. +#============================================================================== + +# Printable characters for escapes +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\\fart0]|x([0-9a-fA-F]{2}))/ + (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex; + return $node; +} + +1; diff --git a/lib/YAML/Loader.pod b/lib/YAML/Loader.pod new file mode 100644 index 0000000..b7f7ffb --- /dev/null +++ b/lib/YAML/Loader.pod @@ -0,0 +1,39 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=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 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Loader/Base.pm b/lib/YAML/Loader/Base.pm new file mode 100644 index 0000000..6a3504c --- /dev/null +++ b/lib/YAML/Loader/Base.pm @@ -0,0 +1,33 @@ +package YAML::Loader::Base; + +use YAML::Mo; + +has load_code => default => sub {0}; +has stream => default => sub {''}; +has document => default => sub {0}; +has line => default => sub {0}; +has documents => default => sub {[]}; +has lines => default => sub {[]}; +has eos => default => sub {0}; +has done => default => sub {0}; +has anchor2node => default => sub {{}}; +has level => default => sub {0}; +has offset => default => sub {[]}; +has preface => default => sub {''}; +has content => default => sub {''}; +has indent => default => sub {0}; +has major_version => default => sub {0}; +has minor_version => default => sub {0}; +has inline => default => sub {''}; + +sub set_global_options { + my $self = shift; + $self->load_code($YAML::LoadCode || $YAML::UseCode) + if defined $YAML::LoadCode or defined $YAML::UseCode; +} + +sub load { + die 'load() not implemented in this class.'; +} + +1; diff --git a/lib/YAML/Loader/Base.pod b/lib/YAML/Loader/Base.pod new file mode 100644 index 0000000..a0ccb98 --- /dev/null +++ b/lib/YAML/Loader/Base.pod @@ -0,0 +1,35 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Loader::Base - Base class for YAML Loader classes + +=head1 SYNOPSIS + + package YAML::Loader::Something; + use YAML::Loader::Base -base; + +=head1 DESCRIPTION + +YAML::Loader::Base is a base class for creating YAML loader classes. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Marshall.pm b/lib/YAML/Marshall.pm new file mode 100644 index 0000000..14d378b --- /dev/null +++ b/lib/YAML/Marshall.pm @@ -0,0 +1,47 @@ +use strict; use warnings; +package YAML::Marshall; + +use YAML::Node (); + +sub import { + my $class = shift; + no strict 'refs'; + my $package = caller; + unless (grep { $_ eq $class} @{$package . '::ISA'}) { + push @{$package . '::ISA'}, $class; + } + + my $tag = shift; + if ( $tag ) { + no warnings 'once'; + $YAML::TagClass->{$tag} = $package; + ${$package . "::YamlTag"} = $tag; + } +} + +sub yaml_dump { + my $self = shift; + no strict 'refs'; + my $tag = ${ref($self) . "::YamlTag"} || 'perl/' . ref($self); + $self->yaml_node($self, $tag); +} + +sub yaml_load { + my ($class, $node) = @_; + if (my $ynode = $class->yaml_ynode($node)) { + $node = $ynode->{NODE}; + } + bless $node, $class; +} + +sub yaml_node { + shift; + YAML::Node->new(@_); +} + +sub yaml_ynode { + shift; + YAML::Node::ynode(@_); +} + +1; diff --git a/lib/YAML/Marshall.pod b/lib/YAML/Marshall.pod new file mode 100644 index 0000000..948d9a6 --- /dev/null +++ b/lib/YAML/Marshall.pod @@ -0,0 +1,36 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Marshall - YAML marshalling class you can mixin to your classes + +=head1 SYNOPSIS + + package Bar; + use Foo -base; + use YAML::Marshall -mixin; + +=head1 DESCRIPTION + +For classes that want to handle their own YAML serialization. + +=head1 AUTHOR + +ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Mo.pm b/lib/YAML/Mo.pm new file mode 100644 index 0000000..c669ff0 --- /dev/null +++ b/lib/YAML/Mo.pm @@ -0,0 +1,80 @@ +package YAML::Mo; $VERSION = '0.88'; +# use Mo qw[builder default import]; +# The following line of code was produced from the previous line by +# Mo::Inline version 0.31 +no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{bless{@_[1..$#_]},$_[0]};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;$a{default}or return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$a{default}->(@_):$m->(@_)}}};my$i=\&import;*{$M.import}=sub{(@_==2 and not $_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};@f=qw[builder default import];use strict;use warnings; + +our $DumperModule = 'Data::Dumper'; + +my ($_new_error, $_info, $_scalar_info); + +no strict 'refs'; +*{$M.'Object::die'} = sub { + my $self = shift; + my $error = $self->$_new_error(@_); + $error->type('Error'); + Carp::croak($error->format_message); +}; + +*{$M.'Object::warn'} = sub { + my $self = shift; + return unless $^W; + my $error = $self->$_new_error(@_); + $error->type('Warning'); + Carp::cluck($error->format_message); +}; + +# This code needs to be refactored to be simpler and more precise, and no, +# Scalar::Util doesn't DWIM. +# +# Can't handle: +# * blessed regexp +*{$M.'Object::node_info'} = sub { + my $self = shift; + my $stringify = $_[1] || 0; + my ($class, $type, $id) = + ref($_[0]) + ? $stringify + ? &$_info("$_[0]") + : do { + require overload; + my @info = &$_info(overload::StrVal($_[0])); + if (ref($_[0]) eq 'Regexp') { + @info[0, 1] = (undef, 'REGEXP'); + } + @info; + } + : &$_scalar_info($_[0]); + ($class, $type, $id) = &$_scalar_info("$_[0]") + unless $id; + return wantarray ? ($class, $type, $id) : $id; +}; + +#------------------------------------------------------------------------------- +$_info = sub { + return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o); +}; + +$_scalar_info = sub { + my $id = 'undef'; + if (defined $_[0]) { + \$_[0] =~ /\((\w+)\)$/o or CORE::die(); + $id = "$1-S"; + } + return (undef, undef, $id); +}; + +$_new_error = sub { + require Carp; + my $self = shift; + require YAML::Error; + + my $code = shift || 'unknown error'; + my $error = YAML::Error->new(code => $code); + $error->line($self->line) if $self->can('line'); + $error->document($self->document) if $self->can('document'); + $error->arguments([@_]); + return $error; +}; + +1; diff --git a/lib/YAML/Node.pm b/lib/YAML/Node.pm new file mode 100644 index 0000000..81c2727 --- /dev/null +++ b/lib/YAML/Node.pm @@ -0,0 +1,218 @@ +use strict; use warnings; +package YAML::Node; + +use YAML::Tag; +require YAML::Mo; + +use Exporter; +our @ISA = qw(Exporter YAML::Mo::Object); +our @EXPORT = qw(ynode); + +sub ynode { + my $self; + if (ref($_[0]) eq 'HASH') { + $self = tied(%{$_[0]}); + } + elsif (ref($_[0]) eq 'ARRAY') { + $self = tied(@{$_[0]}); + } + elsif (ref(\$_[0]) eq 'GLOB') { + $self = tied(*{$_[0]}); + } + else { + $self = tied($_[0]); + } + return (ref($self) =~ /^yaml_/) ? $self : undef; +} + +sub new { + my ($class, $node, $tag) = @_; + my $self; + $self->{NODE} = $node; + my (undef, $type) = YAML::Mo::Object->node_info($node); + $self->{KIND} = (not defined $type) ? 'scalar' : + ($type eq 'ARRAY') ? 'sequence' : + ($type eq 'HASH') ? 'mapping' : + $class->die("Can't create YAML::Node from '$type'"); + tag($self, ($tag || '')); + if ($self->{KIND} eq 'scalar') { + yaml_scalar->new($self, $_[1]); + return \ $_[1]; + } + my $package = "yaml_" . $self->{KIND}; + $package->new($self) +} + +sub node { $_->{NODE} } +sub kind { $_->{KIND} } +sub tag { + my ($self, $value) = @_; + if (defined $value) { + $self->{TAG} = YAML::Tag->new($value); + return $self; + } + else { + return $self->{TAG}; + } +} +sub keys { + my ($self, $value) = @_; + if (defined $value) { + $self->{KEYS} = $value; + return $self; + } + else { + return $self->{KEYS}; + } +} + +#============================================================================== +package yaml_scalar; + +@yaml_scalar::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + tie $_[2], $class, $self; +} + +sub TIESCALAR { + my ($class, $self) = @_; + bless $self, $class; + $self +} + +sub FETCH { + my ($self) = @_; + $self->{NODE} +} + +sub STORE { + my ($self, $value) = @_; + $self->{NODE} = $value +} + +#============================================================================== +package yaml_sequence; + +@yaml_sequence::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + my $new; + tie @$new, $class, $self; + $new +} + +sub TIEARRAY { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCHSIZE { + my ($self) = @_; + scalar @{$self->{NODE}}; +} + +sub FETCH { + my ($self, $index) = @_; + $self->{NODE}[$index] +} + +sub STORE { + my ($self, $index, $value) = @_; + $self->{NODE}[$index] = $value +} + +sub undone { + die "Not implemented yet"; # XXX +} + +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*STORESIZE = *POP = *PUSH = *SHIFT = *UNSHIFT = *SPLICE = *DELETE = *EXISTS = +*undone; # XXX Must implement before release + +#============================================================================== +package yaml_mapping; + +@yaml_mapping::ISA = qw(YAML::Node); + +sub new { + my ($class, $self) = @_; + @{$self->{KEYS}} = sort keys %{$self->{NODE}}; + my $new; + tie %$new, $class, $self; + $new +} + +sub TIEHASH { + my ($class, $self) = @_; + bless $self, $class +} + +sub FETCH { + my ($self, $key) = @_; + if (exists $self->{NODE}{$key}) { + return (grep {$_ eq $key} @{$self->{KEYS}}) + ? $self->{NODE}{$key} : undef; + } + return $self->{HASH}{$key}; +} + +sub STORE { + my ($self, $key, $value) = @_; + if (exists $self->{NODE}{$key}) { + $self->{NODE}{$key} = $value; + } + elsif (exists $self->{HASH}{$key}) { + $self->{HASH}{$key} = $value; + } + else { + if (not grep {$_ eq $key} @{$self->{KEYS}}) { + push(@{$self->{KEYS}}, $key); + } + $self->{HASH}{$key} = $value; + } + $value +} + +sub DELETE { + my ($self, $key) = @_; + my $return; + if (exists $self->{NODE}{$key}) { + $return = $self->{NODE}{$key}; + } + elsif (exists $self->{HASH}{$key}) { + $return = delete $self->{NODE}{$key}; + } + for (my $i = 0; $i < @{$self->{KEYS}}; $i++) { + if ($self->{KEYS}[$i] eq $key) { + splice(@{$self->{KEYS}}, $i, 1); + } + } + return $return; +} + +sub CLEAR { + my ($self) = @_; + @{$self->{KEYS}} = (); + %{$self->{HASH}} = (); +} + +sub FIRSTKEY { + my ($self) = @_; + $self->{ITER} = 0; + $self->{KEYS}[0] +} + +sub NEXTKEY { + my ($self) = @_; + $self->{KEYS}[++$self->{ITER}] +} + +sub EXISTS { + my ($self, $key) = @_; + exists $self->{NODE}{$key} +} + +1; diff --git a/lib/YAML/Node.pod b/lib/YAML/Node.pod new file mode 100644 index 0000000..7abd968 --- /dev/null +++ b/lib/YAML/Node.pod @@ -0,0 +1,91 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Node - A generic data node that encapsulates YAML information + +=head1 SYNOPSIS + + use YAML; + use YAML::Node; + + my $ynode = YAML::Node->new({}, 'ingerson.com/fruit'); + %$ynode = qw(orange orange apple red grape green); + print Dump $ynode; + +yields: + + --- !ingerson.com/fruit + orange: orange + apple: red + grape: green + +=head1 DESCRIPTION + +A generic node in YAML is similar to a plain hash, array, or scalar node in +Perl except that it must also keep track of its type. The type is a URI called +the YAML type tag. + +YAML::Node is a class for generating and manipulating these containers. A YAML +node (or ynode) is a tied hash, array or scalar. In most ways it behaves just +like the plain thing. But you can assign and retrieve and YAML type tag URI to +it. For the hash flavor, you can also assign the order that the keys will be +retrieved in. By default a ynode will offer its keys in the same order that +they were assigned. + +YAML::Node has a class method call new() that will return a ynode. You pass +it a regular node and an optional type tag. After that you can use it like +a normal Perl node, but when you YAML::Dump it, the magical properties will +be honored. + +This is how you can control the sort order of hash keys during a YAML +serialization. By default, YAML sorts keys alphabetically. But notice in the +above example that the keys were Dumped in the same order they were assigned. + +YAML::Node exports a function called ynode(). This function returns the tied +object so that you can call special methods on it like ->keys(). + +keys() works like this: + + use YAML; + use YAML::Node; + + %$node = qw(orange orange apple red grape green); + $ynode = YAML::Node->new($node); + ynode($ynode)->keys(['grape', 'apple']); + print Dump $ynode; + +produces: + + --- + grape: green + apple: red + +It tells the ynode which keys and what order to use. + +ynodes will play a very important role in how programs use YAML. They are +the foundation of how a Perl class can marshall the Loading and Dumping of +its objects. + +The upcoming versions of YAML.pm will have much more information on this. + +=head1 AUTHOR + +Ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Tag.pm b/lib/YAML/Tag.pm new file mode 100644 index 0000000..57aef46 --- /dev/null +++ b/lib/YAML/Tag.pm @@ -0,0 +1,19 @@ +use strict; use warnings; +package YAML::Tag; + +use overload '""' => sub { ${$_[0]} }; + +sub new { + my ($class, $self) = @_; + bless \$self, $class +} + +sub short { + ${$_[0]} +} + +sub canonical { + ${$_[0]} +} + +1; diff --git a/lib/YAML/Tag.pod b/lib/YAML/Tag.pod new file mode 100644 index 0000000..982176d --- /dev/null +++ b/lib/YAML/Tag.pod @@ -0,0 +1,34 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Tag - Tag URI object class for YAML + +=head1 SYNOPSIS + + use YAML::Tag; + +=head1 DESCRIPTION + +Used by YAML::Node. + +=head1 AUTHOR + +ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 diff --git a/lib/YAML/Types.pm b/lib/YAML/Types.pm new file mode 100644 index 0000000..8cbbde2 --- /dev/null +++ b/lib/YAML/Types.pm @@ -0,0 +1,235 @@ +package YAML::Types; + +use YAML::Mo; +use YAML::Node; + +# XXX These classes and their APIs could still use some refactoring, +# but at least they work for now. +#------------------------------------------------------------------------------- +package YAML::Type::blessed; + +use YAML::Mo; # XXX + +sub yaml_dump { + my $self = shift; + my ($value) = @_; + my ($class, $type) = YAML::Mo::Object->node_info($value); + no strict 'refs'; + my $kind = lc($type) . ':'; + my $tag = ${$class . '::ClassTag'} || + "!perl/$kind$class"; + if ($type eq 'REF') { + YAML::Node->new( + {(&YAML::VALUE, ${$_[0]})}, $tag + ); + } + elsif ($type eq 'SCALAR') { + $_[1] = $$value; + YAML::Node->new($_[1], $tag); + } + elsif ($type eq 'GLOB') { + # blessed glob support is minimal, and will not round-trip + # initial aim: to not cause an error + return YAML::Type::glob->yaml_dump($value, $tag); + } else { + YAML::Node->new($value, $tag); + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::undef; + +sub yaml_dump { + my $self = shift; +} + +sub yaml_load { + my $self = shift; +} + +#------------------------------------------------------------------------------- +package YAML::Type::glob; + +sub yaml_dump { + my $self = shift; + # $_[0] remains as the glob + my $tag = pop @_ if 2==@_; + + $tag = '!perl/glob:' unless defined $tag; + my $ynode = YAML::Node->new({}, $tag); + for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { + my $value = *{$_[0]}{$type}; + $value = $$value if $type eq 'SCALAR'; + if (defined $value) { + if ($type eq 'IO') { + my @stats = qw(device inode mode links uid gid rdev size + atime mtime ctime blksize blocks); + undef $value; + $value->{stat} = YAML::Node->new({}); + if ($value->{fileno} = fileno(*{$_[0]})) { + local $^W; + map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); + $value->{tell} = tell(*{$_[0]}); + } + } + $ynode->{$type} = $value; + } + } + return $ynode; +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + my ($name, $package); + if (defined $node->{NAME}) { + $name = $node->{NAME}; + delete $node->{NAME}; + } + else { + $loader->warn('YAML_LOAD_WARN_GLOB_NAME'); + return undef; + } + if (defined $node->{PACKAGE}) { + $package = $node->{PACKAGE}; + delete $node->{PACKAGE}; + } + else { + $package = 'main'; + } + no strict 'refs'; + if (exists $node->{SCALAR}) { + *{"${package}::$name"} = \$node->{SCALAR}; + delete $node->{SCALAR}; + } + for my $elem (qw(ARRAY HASH CODE IO)) { + if (exists $node->{$elem}) { + if ($elem eq 'IO') { + $loader->warn('YAML_LOAD_WARN_GLOB_IO'); + delete $node->{IO}; + next; + } + *{"${package}::$name"} = $node->{$elem}; + delete $node->{$elem}; + } + } + for my $elem (sort keys %$node) { + $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem); + } + return *{"${package}::$name"}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::code; + +my $dummy_warned = 0; +my $default = '{ "DUMMY" }'; + +sub yaml_dump { + my $self = shift; + my $code; + my ($dumpflag, $value) = @_; + my ($class, $type) = YAML::Mo::Object->node_info($value); + my $tag = "!perl/code"; + $tag .= ":$class" if defined $class; + if (not $dumpflag) { + $code = $default; + } + else { + bless $value, "CODE" if $class; + eval { use B::Deparse }; + return if $@; + my $deparse = B::Deparse->new(); + eval { + local $^W = 0; + $code = $deparse->coderef2text($value); + }; + if ($@) { + warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W; + $code = $default; + } + bless $value, $class if $class; + chomp $code; + $code .= "\n"; + } + $_[2] = $code; + YAML::Node->new($_[2], $tag); +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + if ($loader->load_code) { + my $code = eval "package main; sub $node"; + if ($@) { + $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@); + return sub {}; + } + else { + CORE::bless $code, $class if $class; + return $code; + } + } + else { + return CORE::bless sub {}, $class if $class; + return sub {}; + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::ref; + +sub yaml_dump { + my $self = shift; + YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref') +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr') + unless exists $node->{&YAML::VALUE}; + return \$node->{&YAML::VALUE}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::regexp; + +# XXX Be sure to handle blessed regexps (if possible) +sub yaml_dump { + die "YAML::Type::regexp::yaml_dump not currently implemented"; +} + +use constant _QR_TYPES => { + '' => sub { qr{$_[0]} }, + x => sub { qr{$_[0]}x }, + i => sub { qr{$_[0]}i }, + s => sub { qr{$_[0]}s }, + m => sub { qr{$_[0]}m }, + ix => sub { qr{$_[0]}ix }, + sx => sub { qr{$_[0]}sx }, + mx => sub { qr{$_[0]}mx }, + si => sub { qr{$_[0]}si }, + mi => sub { qr{$_[0]}mi }, + ms => sub { qr{$_[0]}sm }, + six => sub { qr{$_[0]}six }, + mix => sub { qr{$_[0]}mix }, + msx => sub { qr{$_[0]}msx }, + msi => sub { qr{$_[0]}msi }, + msix => sub { qr{$_[0]}msix }, +}; + +sub yaml_load { + my $self = shift; + my ($node, $class) = @_; + return qr{$node} unless $node =~ /^\(\?([\^\-xism]*):(.*)\)\z/s; + my ($flags, $re) = ($1, $2); + $flags =~ s/-.*//; + $flags =~ s/^\^//; + my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} }; + my $qr = &$sub($re); + bless $qr, $class if length $class; + return $qr; +} + +1; diff --git a/lib/YAML/Types.pod b/lib/YAML/Types.pod new file mode 100644 index 0000000..1895647 --- /dev/null +++ b/lib/YAML/Types.pod @@ -0,0 +1,38 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.39. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +YAML::Types - Marshall Perl internal data types to/from YAML + +=head1 SYNOPSIS + + $::foo = 42; + print YAML::Dump(*::foo); + + print YAML::Dump(qr{match me}); + +=head1 DESCRIPTION + +This module has the helper classes for transferring objects, subroutines, +references, globs, regexps and file handles to and from YAML. + +=head1 AUTHOR + +ingy döt Net <ingy@cpan.org> + +=head1 COPYRIGHT + +Copyright 2001-2014. Ingy döt Net + +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 |