view release on metacpan or  search on metacpan

lib/Config/Model/BackendMgr.pm  view on Meta::CPAN

#
# This file is part of Config-Model
#
# This software is Copyright (c) 2005-2022 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::BackendMgr 2.162;

use Mouse;
use strict;
use warnings;

use Carp;
use v5.20;

use Config::Model::Exception;
use Data::Dumper;
use Storable qw/dclone/;
use Scalar::Util qw/weaken reftype/;
use Log::Log4perl qw(get_logger :levels);
use Path::Tiny 0.070;

use feature qw/postderef signatures/;
no warnings qw/experimental::postderef experimental::signatures/;

my $logger = get_logger('BackendMgr');
my $user_logger = get_logger('User');

# one BackendMgr per file

has 'node' => (
    is       => 'ro',
    isa      => 'Config::Model::Node',
    weak_ref => 1,
    required => 1
);
has 'file_backup' => ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );

has 'rw_config' => (
    is => 'ro',
    isa => 'HashRef',
    required => 1
);

has 'backend_obj' => (
    is      => 'rw',
    isa     => 'Config::Model::Backend::Any',
    lazy    => 1 ,
    builder => '_build_backend_obj',
);

sub _build_backend_obj {
    my $self = shift;

    my $backend = $self->rw_config->{backend};
    $logger->warn("function parameter for a backend is deprecated. Please implement 'read' method in backend $backend")
        if $self->rw_config->{function};
    # try to load a specific Backend class
    my $f = $self->rw_config->{function} || 'read';
    my $c = $self->load_backend_class( $backend, $f );

    no strict 'refs'; ## no critic (ProhibitNoStrict)
    return $c->new(
        node => $self->node,
        name => $backend,
        auto_create => $self->rw_config->{auto_create},
        auto_delete => $self->rw_config->{auto_delete},
    );
}

has support_annotation => (
    is => 'ro',
    isa => 'Bool',
    default => 0,
);

with "Config::Model::Role::ComputeFunction";
with "Config::Model::Role::FileHandler";

# check if dir is present. May create it in auto_create write mode
sub get_cfg_dir_path ($self, %args) {
    my $w = $args{write} || 0;
    my $dir = $self->get_tuned_config_dir(%args);

    if ( not $dir->is_dir and $w and $args{auto_create} ) {
        $logger->info("creating directory $dir");
        $dir->mkpath;
    }

    unless ( $dir->is_dir ) {
        my $mode = $w ? 'write' : 'read';
        $logger->info( "$args{backend}: missing directory $dir ($mode mode)" );
        return ( 0, $dir );
    }

    $logger->trace( "dir: " . $dir // '<undef>' );

    return ( 1, $dir );
}

# return (1, config file path) constructed from arguments or return
# (0). May create directory in auto_create write mode.
sub get_cfg_file_path ($self, %args) {
    my $w = $args{write} || 0;

    # config file override
    my $cfo = $args{config_file};

    if ( defined $cfo) {
        my $override
            = $args{root}   ? $args{root}->child($cfo)
            : $cfo =~ m!^/! ? path($cfo)
            :                 path('.')->child($cfo);

        my $mode = $w ? 'write' : 'read';
        $logger->trace("$args{backend} override target file is $override ($mode mode)");
        return ( 1, $override );
    }

    my ( $dir_ok, $dir ) = $self->get_cfg_dir_path(%args);

    if ( defined $args{file} ) {
        my $file = $args{skip_compute} ? $args{file} : $self->node->compute_string($args{file});
        my $res = $dir->child($file);
        $logger->trace("get_cfg_file_path: returns $res");
        return ( $dir_ok, $res );
    }

    return 0;
}

sub open_read_file ($self, $file_path) {
    if ( $file_path->is_file ) {
        $logger->debug("open_read_file: open $file_path for read");
        # store a backup in memory in case there's a problem
        $self->file_backup( [ $file_path->lines_utf8 ] );
        return $file_path->filehandle("<", ":utf8");
    }
    else {
        return;
    }
}

# called at configuration node creation
sub load_backend_class ($self, $backend, $function) {
    $logger->trace("load_backend_class: called with backend $backend, function $function");
    my %c;

    my $k = "Config::Model::Backend::" . ucfirst($backend);
    my $f = $k . '.pm';
    $f =~ s!::!/!g;
    $c{$k} = $f;

    # try another class
    $k =~ s/_(\w)/uc($1)/ge;
    $f =~ s/_(\w)/uc($1)/ge;
    $c{$k} = $f;

    foreach my $c ( sort keys %c ) {
        if ( $c->can($function) ) {

            # no need to load class
            $logger->debug("load_backend_class: $c is already loaded (can $function)");
            return $c;
        }
    }

    # look for file to load
    my $class_to_load;
    foreach my $c ( sort keys %c ) {
        $logger->trace("load_backend_class: looking to load class $c");
        foreach my $prefix (@INC) {
            my $realfilename = "$prefix/$c{$c}";
            $class_to_load = $c if -f $realfilename;
        }
    }

    if (not defined  $class_to_load) {
        Config::Model::Exception::Model->throw(
            object => $self->node,
            error => "backend error: cannot find Perl class for backend: '$backend'",
        );
    };
    my $file_to_load = $c{$class_to_load};

    $logger->trace("load_backend_class: loading class $class_to_load, $file_to_load");
    eval { require $file_to_load; };

    if ($@) {
        die "Error with backend $backend: could not parse $file_to_load: $@\n";
    }
    return $class_to_load;
}

sub read_config_data ($self, %args) {
    $logger->trace( "called for node ", $self->node->location );

lib/Config/Model/BackendMgr.pm  view on Meta::CPAN

        $error->rethrow ;
    }
    elsif ( ref $error ) {
        die $error ;
    }
    elsif ( $error ) {
        die "Backend $backend failed to read $file_path: $error";
    }

    # only backend based on C::M::Backend::Any can support annotations
    if ($backend_obj->can('annotation')) {
        $self->{support_annotation} = $backend_obj->annotation ;
    }

    return ( $res, $file_path );
}

sub auto_write_init ($self) {
    my $rw_config = dclone $self->rw_config ;

    my $instance = $self->node->instance();

    # root override is passed by the instance
    my $root_dir = $instance->root_dir;

    my $backend = $rw_config->{backend};

    my $write_dir = $self->get_tuned_config_dir(%$rw_config);

    $logger->trace( "auto_write_init creating write cb ($backend) for ", $self->node->name );

    my @wr_args = (
        %$rw_config,            # model data
        config_dir  => $write_dir,    # override from instance
        write       => 1,             # for get_cfg_file_path
        root        => $root_dir,     # override from instance
    );

    # used bby C::M::Dumper and C::M::DumpAsData
    $self->{auto_write}{$backend} = 1;

    my $wb;
    my $f = $rw_config->{function} || 'write';
    my $backend_class = $self->load_backend_class( $backend, $f );
    my $location = $self->node->name;
    my $node = $self->node;     # closure

    # provide a proper write back function
    $wb = sub (%cb_args) {
        my $force_delete = delete $cb_args{force_delete} ;
        $logger->debug( "write cb ($backend) called for $location ", $force_delete ? '' : ' (deleted)' );
        my $backend_obj = $self->backend_obj();

        my ($fh, $file_ok, $file_path );

        if (not $backend_class->skip_open) {
            ( $file_ok, $file_path ) = $self->get_cfg_file_path( @wr_args, %cb_args);
        }

        if ($file_ok) {
            $fh = $self->open_file_to_write( $backend, $file_path, delete $cb_args{backup} );
        }

        # override needed for "save as" button
        my %backend_args = (
            @wr_args,
            file_path => $file_path,
            object    => $node,
            %cb_args            # override from user
        );

        my $res;
        if ($force_delete) {
            $backend_obj->delete(%backend_args);
        }
        else {
            $res = eval { $backend_obj->$f( %backend_args ); };
            my $error = $@;
            $logger->error( "write backend $backend $backend_class" . '::' . "$f failed: $error" )
                if $error;
            $self->close_file_to_write( $error, $file_path, $rw_config->{file_mode} );

            $self->auto_delete($file_path, \%backend_args)
                if $rw_config->{auto_delete} and not $backend_class->skip_open ;
        }

        return defined $res ? $res : $@ ? 0 : 1;
    };

    $logger->trace( "registering write $backend in node " . $self->node->name );

    $instance->register_write_back(  $self->node->location, $backend, $wb  );
    return;
}

sub auto_delete ($self, $file_path, $args) {

    return unless $file_path;

    my $perl_data;
    $perl_data = $self->node->dump_as_data( full_dump => $args->{full_dump} // 0)
        if defined $self->node;

    my $size = ref($perl_data) eq 'HASH'  ? scalar keys %$perl_data
             : ref($perl_data) eq 'ARRAY' ? scalar @$perl_data
             :                              $perl_data ;
    if (not $size) {
        $logger->info( "Removing $file_path (no data to store)" );
        unlink($file_path);
    }
    return;
}


sub open_file_to_write ($self, $backend, $file_path, $backup) {
    my $do_backup = defined $backup;
    $backup ||= 'old';    # use old only if defined
    $backup = '.' . $backup unless $backup =~ /^\./;

    # make sure that parent dir exists before creating file
    $file_path->parent->mkpath;

    if ( $do_backup and $file_path->is_file ) {
        $file_path->copy( $file_path.$backup ) or die "Backup copy failed: $!";
    }

    $logger->debug("$backend backend opened file $file_path to write");
    return $file_path->filehandle(">",":utf8");
}

sub close_file_to_write ($self, $error, $file_path, $file_mode) {

    return unless defined $file_path;

    if ($error) {
        # restore backup and display error
        $logger->warn("Error during write, restoring backup data in $file_path" );
        $file_path->append_utf8({ truncate => 1 }, $self->file_backup );
        $error->rethrow if ref($error) and $error->can('rethrow');
        die $error;
    }

    # TODO: move chmod in a backend role
    $file_path->chmod($file_mode) if $file_mode;

    # TODO: move in a backend role
    # check file size and remove empty files
    $file_path->remove if -z $file_path and not -l $file_path;

    return;
}

sub is_auto_write_for_type ($self, $type) {
    return $self->{auto_write}{$type} || 0;
}

__PACKAGE__->meta->make_immutable;

1;

# ABSTRACT: Load configuration node on demand

__END__

=pod

=encoding UTF-8

=head1 NAME

Config::Model::BackendMgr - Load configuration node on demand

=head1 VERSION

version 2.162

=head1 SYNOPSIS

 # Use BackendMgr to write data in Yaml file
 # This example requires Config::Model::Backend::Yaml which is now
 # shipped outside of Config::Model. Please get it on CPAN
 use Config::Model;

 # define configuration tree object
 my $model = Config::Model->new;
 $model->create_config_class(
    name    => "Foo",
    element => [
        [qw/foo bar/] => {
            type       => 'leaf',
            value_type => 'string'
        },
    ]
 );

 $model->create_config_class(
    name => "MyClass",