File Coverage

blib/lib/YAML/PP.pm

Criterion	Covered	Total	%
statement	221	229	96.5
branch	30	36	83.3
condition	24	27	88.8
subroutine	62	63	98.4
pod	17	18	94.4
total	354	373	94.9

# ABSTRACT: YAML 1.2 Processor
use strict;
use warnings;
package YAML::PP;

our $VERSION = 'v0.40.0'; # VERSION

use YAML::PP::Schema;
use YAML::PP::Schema::JSON;
use YAML::PP::Loader;
use YAML::PP::Dumper;
use Scalar::Util qw/ blessed /;
use Carp qw/ croak /;

use base 'Exporter';
our @EXPORT_OK = qw/ Load LoadFile Dump DumpFile /;

my %YAML_VERSIONS = ('1.1' => 1, '1.2' => 1);


sub new {
    my ($class, %args) = @_;

    my $bool = delete $args{boolean};
    $bool = 'perl' unless defined $bool;
    my $schemas = delete $args{schema} || ['+'];
    my $cyclic_refs = delete $args{cyclic_refs} || 'fatal';
    my $indent = delete $args{indent};
    my $width = delete $args{width};
    my $writer = delete $args{writer};
    my $header = delete $args{header};
    my $footer = delete $args{footer};
    my $require_footer = delete $args{require_footer};
    my $duplicate_keys = delete $args{duplicate_keys};
    my $max_depth = delete $args{max_depth};
    my $yaml_version = $class->_arg_yaml_version(delete $args{yaml_version});
    my $default_yaml_version = $yaml_version->[0];
    my $version_directive = delete $args{version_directive};
    my $preserve = delete $args{preserve};
    my $parser = delete $args{parser};
    my $emitter = delete $args{emitter} || {
        indent => $indent,
        width => $width,
        writer => $writer,
    };
    if (keys %args) {
        die "Unexpected arguments: " . join ', ', sort keys %args;
    }

    my %schemas;
    for my $v (@$yaml_version) {
        my $schema;
        if (blessed($schemas) and $schemas->isa('YAML::PP::Schema')) {
            $schema = $schemas;
        }
        else {
            $schema = YAML::PP::Schema->new(
                boolean => $bool,
                yaml_version => $v,
            );
            $schema->load_subschemas(@$schemas);
        }
        $schemas{ $v } = $schema;
    }
    my $default_schema = $schemas{ $default_yaml_version };

    my $loader = YAML::PP::Loader->new(
        schemas => \%schemas,
        cyclic_refs => $cyclic_refs,
        parser => $parser,
        default_yaml_version => $default_yaml_version,
        preserve => $preserve,
        duplicate_keys => $duplicate_keys,
        require_footer => $require_footer,
        max_depth => $max_depth,
    );
    my $dumper = YAML::PP::Dumper->new(
        schema => $default_schema,
        emitter => $emitter,
        header => $header,
        footer => $footer,
        version_directive => $version_directive,
        preserve => $preserve,
    );

    my $self = bless {
        schema => \%schemas,
        loader => $loader,
        dumper => $dumper,
    }, $class;
    return $self;
}

sub clone {
    my ($self) = @_;
    my $clone = {
        schema => $self->schema,
        loader => $self->loader->clone,
        dumper => $self->dumper->clone,
    };
    return bless $clone, ref $self;
}

sub _arg_yaml_version {
    my ($class, $version) = @_;
    my @versions = ('1.2');
    if (defined $version) {
        @versions = ();
        if (not ref $version) {
            $version = [$version];
        }
        for my $v (@$version) {
            unless ($YAML_VERSIONS{ $v }) {
                croak "YAML Version '$v' not supported";
            }
            push @versions, $v;
        }
    }
    return \@versions;
}


sub loader {
    if (@_ > 1) {
        $_[0]->{loader} = $_[1]
    }
    return $_[0]->{loader};
}

sub dumper {
    if (@_ > 1) {
        $_[0]->{dumper} = $_[1]
    }
    return $_[0]->{dumper};
}

sub schema {
    if (@_ > 1) { $_[0]->{schema}->{'1.2'} = $_[1] }
    return $_[0]->{schema}->{'1.2'};
}

sub default_schema {
    my ($self, %args) = @_;
    my $schema = YAML::PP::Schema->new(
        boolean => $args{boolean},
    );
    $schema->load_subschemas(qw/ Core /);
    return $schema;
}

sub load_string {
    my ($self, $yaml) = @_;
    return $self->loader->load_string($yaml);
}

sub load_file {
    my ($self, $file) = @_;
    return $self->loader->load_file($file);
}

sub dump {
    my ($self, @data) = @_;
    return $self->dumper->dump(@data);
}

sub dump_string {
    my ($self, @data) = @_;
    return $self->dumper->dump_string(@data);
}

sub dump_file {
    my ($self, $file, @data) = @_;
    return $self->dumper->dump_file($file, @data);
}

# legagy interface
sub Load {
    my ($yaml) = @_;
    YAML::PP->new->load_string($yaml);
}

sub LoadFile {
    my ($file) = @_;
    YAML::PP->new->load_file($file);
}

sub Dump {
    my (@data) = @_;
    YAML::PP->new->dump_string(@data);
}

sub DumpFile {
    my ($file, @data) = @_;
    YAML::PP->new->dump_file($file, @data);
}

sub preserved_scalar {
    my ($self, $value, %args) = @_;
    my $scalar = YAML::PP::Preserve::Scalar->new(
        value => $value,
        %args,
    );
    return $scalar;
}

sub preserved_mapping {
    my ($self, $hash, %args) = @_;
    my $data = {};
    tie %$data, 'YAML::PP::Preserve::Hash';
    %$data = %$hash;
    my $t = tied %$data;
    $t->{style} = $args{style};
    $t->{alias} = $args{alias};
    return $data;
}

sub preserved_sequence {
    my ($self, $array, %args) = @_;
    my $data = [];
    tie @$data, 'YAML::PP::Preserve::Array';
    push @$data, @$array;
    my $t = tied @$data;
    $t->{style} = $args{style};
    $t->{alias} = $args{alias};
    return $data;
}

package YAML::PP::Preserve::Hash;
# experimental
use Tie::Hash;
use base qw/ Tie::StdHash /;
use Scalar::Util qw/ reftype blessed /;

sub TIEHASH {
    my ($class, %args) = @_;
    my $self = bless {
        keys => [keys %args],
        data => { %args },
    }, $class;
}

sub STORE {
    my ($self, $key, $val) = @_;
    my $keys = $self->{keys};
    unless (exists $self->{data}->{ $key }) {
        push @$keys, $key;
    }
    if (ref $val and not blessed($val)) {
        if (reftype($val) eq 'HASH' and not tied %$val) {
            tie %$val, 'YAML::PP::Preserve::Hash', %$val;
        }
        elsif (reftype($val) eq 'ARRAY' and not tied @$val) {
            tie @$val, 'YAML::PP::Preserve::Array', @$val;
        }
    }
    $self->{data}->{ $key } = $val;
}

sub FIRSTKEY {
    my ($self) = @_;
    return $self->{keys}->[0];
}

sub NEXTKEY {
    my ($self, $last) = @_;
    my $keys = $self->{keys};
    for my $i (0 .. $#$keys) {
        if ("$keys->[ $i ]" eq "$last") {
            return $keys->[ $i + 1 ];
        }
    }
    return;
}

sub FETCH {
    my ($self, $key) = @_;
    my $val = $self->{data}->{ $key };
}

sub DELETE {
    my ($self, $key) = @_;
    @{ $self->{keys} } = grep { "$_" ne "$key" } @{ $self->{keys} };
    delete $self->{data}->{ $key };
}

sub EXISTS {
    my ($self, $key) = @_;
    return exists $self->{data}->{ $key };
}

sub CLEAR {
    my ($self) = @_;
    $self->{keys} = [];
    $self->{data} = {};
}

sub SCALAR {
    my ($self) = @_;
    return scalar %{ $self->{data} };
}

package YAML::PP::Preserve::Array;
# experimental
use Tie::Array;
use base qw/ Tie::StdArray /;
use Scalar::Util qw/ reftype blessed /;

sub TIEARRAY {
    my ($class, @items) = @_;
    my $self = bless {
        data => [@items],
    }, $class;
    return $self;
}

sub FETCH {
    my ($self, $i) = @_;
    return $self->{data}->[ $i ];
}
sub FETCHSIZE {
    my ($self) = @_;
    return $#{ $self->{data} } + 1;
}

sub _preserve {
    my ($val) = @_;
    if (ref $val and not blessed($val)) {
        if (reftype($val) eq 'HASH' and not tied %$val) {
            tie %$val, 'YAML::PP::Preserve::Hash', %$val;
        }
        elsif (reftype($val) eq 'ARRAY' and not tied @$val) {
            tie @$val, 'YAML::PP::Preserve::Array', @$val;
        }
    }
    return $val;
}

sub STORE {
    my ($self, $i, $val) = @_;
    _preserve($val);
    $self->{data}->[ $i ] = $val;
}
sub PUSH {
    my ($self, @args) = @_;
    push @{ $self->{data} }, map { _preserve $_ } @args;
}
sub STORESIZE {
    my ($self, $i) = @_;
    $#{ $self->{data} } = $i - 1;
}
sub DELETE {
    my ($self, $i) = @_;
    delete $self->{data}->[ $i ];
}
sub EXISTS {
    my ($self, $i) = @_;
    return exists $self->{data}->[ $i ];
}
sub CLEAR {
    my ($self) = @_;
    $self->{data} = [];
}
sub SHIFT {
    my ($self) = @_;
    shift @{ $self->{data} };
}
sub UNSHIFT {
    my ($self, @args) = @_;
    unshift @{ $self->{data} }, map { _preserve $_ } @args;
}
sub SPLICE {
    my ($self, $offset, $length, @args) = @_;
    splice @{ $self->{data} }, $offset, $length, map { _preserve $_ } @args;
}
sub EXTEND {}


package YAML::PP::Preserve::Scalar;

use overload
    fallback => 1,
    '+' => \&value,
    '""' => \&value,
    'bool' => \&value,
    ;
sub new {
    my ($class, %args) = @_;
    my $self = {
        %args,
    };
    bless $self, $class;
}
sub value { $_[0]->{value} }
sub tag { $_[0]->{tag} }
sub style { $_[0]->{style} || 0 }
sub alias { $_[0]->{alias} }

1;

__END__