File Coverage

blib/lib/Config/Model/Backend/Yaml.pm

Criterion	Covered	Total	%
statement	75	80	93.7
branch	6	10	60.0
condition	7	10	70.0
subroutine	21	21	100.0
pod	2	3	66.6
total	111	124	89.5

#
# This file is part of Config-Model-Backend-Yaml
#
# This software is Copyright (c) 2018 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::Yaml;
$Config::Model::Backend::Yaml::VERSION = '2.132';
use 5.10.1;
use Carp;
use strict;
use warnings;
use Config::Model 2.131;
use Config::Model::Exception;
use File::Path;
use Log::Log4perl qw(get_logger :levels);
use boolean;
use YAML::XS 0.69;

use base qw/Config::Model::Backend::Any/;

my $logger = get_logger("Backend::Yaml");

sub single_element {
    my $self = shift;

    my @elts = $self->node->children;
    return if @elts != 1;

    my $obj = $self->node->fetch_element($elts[0]);
    my $type = $obj->get_type;
    return $type =~ /^(list|hash)$/ ? $obj : undef ;
}

sub read {
    my $self = shift;
    my %args = @_;

    local $YAML::XS::LoadBlessed = 0;

    # args is:
    # object     => $obj,         # Config::Model::Node object
    # root       => './my_test',  # fake root directory, userd for tests
    # config_dir => /etc/foo',    # absolute path
    # file       => 'foo.conf',   # file name
    # file_path  => './my_test/etc/foo/foo.conf'
    # check      => yes|no|skip

    return 0 unless $args{file_path}->exists;    # no file to read

    # load yaml file
    my $yaml = $args{file_path}->slurp_utf8;

    # convert to perl data
    my $perl_data = Load($yaml) ;
    if ( not defined $perl_data ) {
        my $msg = "No data found in YAML file $args{file_path}";
        if ($args{auto_create}) {
            $logger->info($msg);
        }
        else {
            $logger->warn($msg);
        }
        return 1;
    }

    my $target = $self->single_element // $self->node ;

    # load perl data in tree
    $target->load_data( data => $perl_data, check => $args{check} || 'yes' );
    return 1;
}

sub write {
    my $self = shift;
    my %args = @_;

    # args is:
    # object     => $obj,         # Config::Model::Node object
    # root       => './my_test',  # fake root directory, userd for tests
    # config_dir => /etc/foo',    # absolute path
    # file       => 'foo.conf',   # file name
    # file_path  => './my_test/etc/foo/foo.conf'
    # check      => yes|no|skip

    local $YAML::XS::Boolean = "boolean";

    my $target = $self->single_element // $self->node ;

    my $perl_data = $target->dump_as_data(
        full_dump => $args{full_dump} // 0,
        to_boolean => sub { return boolean($_[0]) }
    );

    my $yaml = Dump( $perl_data );

    $args{file_path}->spew_utf8($yaml);

    return 1;
}

1;

# ABSTRACT: Read and write config as a YAML data structure

__END__