File Coverage

blib/lib/YAML/PP/Schema/Include.pm

Criterion	Covered	Total	%
statement	80	86	93.0
branch	25	30	83.3
condition	2	4	50.0
subroutine	14	15	93.3
pod	0	9	0.0
total	121	144	84.0

use strict;
use warnings;
package YAML::PP::Schema::Include;

our $VERSION = '0.036_001'; # TRIAL VERSION

use Carp qw/ croak /;
use Scalar::Util qw/ weaken /;
use File::Basename qw/ dirname /;

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

    my $paths = delete $args{paths};
    if (defined $paths) {
        unless (ref $paths eq 'ARRAY') {
            $paths = [$paths];
        }
    }
    else {
        $paths = [];
    }
    my $allow_absolute = $args{allow_absolute} || 0;
    my $loader = $args{loader} || \&default_loader;

    my $self = bless {
        paths => $paths,
        allow_absolute => $allow_absolute,
        last_includes => [],
        cached => {},
        loader => $loader,
    }, $class;
    return $self;
}

sub init {
    my ($self) = @_;
    $self->{last_includes} = [];
    $self->{cached} = [];
}

sub paths { $_[0]->{paths} }
sub allow_absolute { $_[0]->{allow_absolute} }
sub yp {
    my ($self, $yp) = @_;
    if (@_ == 2) {
        $self->{yp} = $yp;
        weaken $self->{yp};
        return $yp;
    }
    return $self->{yp};
}

sub register {
    my ($self, %args) = @_;
    my $schema = $args{schema};

    $schema->add_resolver(
        tag => '!include',
        match => [ all => sub { $self->include(@_) } ],
        implicit => 0,
    );
}

sub include {
    my ($self, $constructor, $event) = @_;
    my $yp = $self->yp;
    my $search_paths = $self->paths;
    my $allow_absolute = $self->allow_absolute;

    my $relative = not @$search_paths;
    if ($relative) {
        my $last_includes = $self->{last_includes};
        if (@$last_includes) {
            $search_paths = [ $last_includes->[-1] ];
        }
        else {
            # we are in the top-level file and need to look into
            # the original YAML::PP instance
            my $filename = $yp->loader->filename;
            $search_paths = [dirname $filename];
        }
    }
    my $filename = $event->{value};

    my $fullpath;
    if (File::Spec->file_name_is_absolute($filename)) {
        unless ($allow_absolute) {
            croak "Absolute filenames not allowed";
        }
        $fullpath = $filename;
    }
    else {
        my @paths = File::Spec->splitdir($filename);
        unless ($allow_absolute) {
            # if absolute paths are not allowed, we also may not use upwards ..
            @paths = File::Spec->no_upwards(@paths);
        }
        for my $candidate (@$search_paths) {
            my $test = File::Spec->catfile( $candidate, @paths );
            if (-e $test) {
                $fullpath = $test;
                last;
            }
        }
        croak "File '$filename' not found" unless defined $fullpath;
    }

    if ($self->{cached}->{ $fullpath }++) {
        croak "Circular include '$fullpath'";
    }
    if ($relative) {
        push @{ $self->{last_includes} }, dirname $fullpath;
    }

    # We need a new object because we are still in the parsing and
    # constructing process
    my $clone = $yp->clone;
    my ($data) = $self->loader->($clone, $fullpath);

    if ($relative) {
        pop @{ $self->{last_includes} };
    }
    unless (--$self->{cached}->{ $fullpath }) {
        delete $self->{cached}->{ $fullpath };
    }
    return $data;
}

sub loader {
    my ($self, $code) = @_;
    if (@_ == 2) {
        $self->{loader} = $code;
        return $code;
    }
    return $self->{loader};
}
sub default_loader {
    my ($yp, $filename) = @_;
    $yp->load_file($filename);
}

1;

__END__