view release on metacpan or  search on metacpan

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

has on_change_cb => (
    is  => 'rw',
    traits    => ['Code'],
    isa       => 'CodeRef',
    default   => sub { sub { } },
);

has on_message_cb => (
    traits    => ['Code'],
    is        => 'rw',
    isa       => 'CodeRef',
    default   => sub { sub { say @_; } },
    handles   => {
        show_message => 'execute',
    },
);

# initial_load mode: when data is loaded the first time
has initial_load => (
    is      => 'rw',
    isa     => 'Bool',
    default => 0,
    trigger => \&_trace_initial_load,
    traits  => [qw/Bool/],
    handles => {
        initial_load_start => 'set',
        initial_load_stop  => 'unset',
    } );

sub _trace_initial_load {
    my ( $self, $n, $o ) = @_;
    $logger->debug("switched to $n");
    return;
}

# This array holds a set of sub ref that will be invoked when
# the user requires to write all configuration tree in their
# backend storage.
has _write_back => (
    is      => 'ro',
    isa     => 'HashRef',
    traits  => ['Hash'],
    handles => {
        count_write_back     => 'count',    # mostly for tests
        has_no_write_back    => 'is_empty',
        nodes_to_write_back  => 'keys',
        write_back_node_info => 'get',
        delete_write_back    => 'delete',
        clear_write_back     => 'clear',
    },
    default => sub { {} },
);

sub register_write_back {
    my ($self, $path, $backend, $wb) = @_;
    push @{ $self->_write_back->{$path} //= [] }, [$backend, $wb];
    return;
}

# used for auto_read auto_write feature
has [qw/name application backend_arg backup/] => (
    is  => 'ro',
    isa => 'Maybe[Str]',
);

has 'root_dir' => (
    is => 'ro',
    isa => 'Config::Model::TypeContraints::Path',
    coerce => 1
);

has root_path => (
    is  => 'ro',
    isa => 'Path::Tiny',
    lazy_build => 1,
);

sub _build_root_path {
    my $self = shift;
    my $root_dir = $self->root_dir // '';
    return $root_dir ? path($root_dir) : Path::Tiny->cwd;
}

has [qw/config_dir config_file/] => (
    is  => 'ro',
    isa => 'Config::Model::TypeContraints::Path',
    coerce => 1
);

has tree => (
    is      => 'ro',
    isa     => 'Config::Model::Node',
    builder => '_build_tree',
    lazy    => 1,
    clearer => '_clear_config',
    reader  => 'config_root',
    handles => [qw/apply_fixes deep_check grab grab_value/],
);

sub reset_config {
    my $self = shift;
    $self->_clear_config;
    $self->clear_changes;
    return $self->config_root;
}

sub _build_tree {
    my $self = shift;

    return $self->load_node (
        config_class_name => $self->{root_class_name},
        instance          => $self,
        container         => $self,
        config_file       => $self->{config_file},
    );
}

sub preset_start {
    my $self = shift;
    $logger->info("Starting preset mode");
    carp "Cannot start preset mode during layered mode"

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

    # make sure that root node is loaded
    $self->config_root->init;

    if ($force_write) {
        # make sure that the whole tree is loaded
        my $dump = $self->config_root->dump_tree;
    }

    foreach my $k ( keys %args ) {
        if ($k eq 'config_dir') {
            $args{$k} ||= '';
            $args{$k} .= '/' if $args{$k} and $args{$k} !~ m!/$!;
        }
        elsif ( $k ne 'config_file' ) {
            croak "write_back: wrong parameters $k";
        }
    }

    if ($self->has_no_write_back ) {
        my $info = $self->application ? "the model of application ".$self->application
            : "model ".$self->root_class_name ;
        croak "Don't know how to save data of $self->{name} instance. ",
            "Either $info has no configured ",
            "read/write backend or no node containing a backend was loaded. ",
            "Try with -force option or add read/write backend to $info\n";
    }

    foreach my $path ( sort $self->nodes_to_write_back ) {
        $logger->info("write_back called on node $path");

        if ( $path and $self->{config_file} ) {
            $logger->warn("write_back: cannot override config_file in non root node ($path)");
            delete  $self->{config_file}
        }

        $self->_write_back_node(%args, path => $path, force_write => $force_write) ;
    }
    $self->clear_changes;
    return;
}

sub _write_back_node ($self, %args) {
    my $path = delete $args{path};
    my $force_write   = delete $args{force_write};

    my $node = $self->config_root->grab(
        step => $path,
        type => 'node',
        mode => 'loose',
        autoadd => 0,
    );

    foreach my $wb_info (@{ $self->write_back_node_info($path) }) {
        my ($backend, $cb) = @$wb_info;

        my @wb_args = (
            %args,
            config_file   => $self->{config_file},
            force         => $force_write,
            backup        => $self->backup,
        );

        if (defined $node and ($node->needs_save or $force_write)) {
            my $dir = $args{config_dir};
            mkpath( $dir, 0, oct(755) ) if $dir and not -d $dir;

            # exit when write is successfull
            my $res = $cb->(@wb_args);
            $logger->info( "write_back called with $backend backend, result is ",
                           defined $res ? $res : '<undef>' );
        }

        if (not defined $node) {
            $logger->debug("deleting file for deleted node $path");
            $cb->(@wb_args, force_delete => 1);
            $self->delete_write_back($path);
        }
    }

    $logger->trace( "write_back on node '$path' done" );
    return;
}

sub save {
    goto &write_back;
}

sub update {
    my ($self, %args) = @_;

    my $hook = sub {
        my ($scanner, $data_ref,$node,@element_list) = @_;
        if ($node->can('update')) {
            my $loc = $node->location;
            say "Calling update on node '$loc'" if $loc and not $args{quiet};
            push (@$data_ref, $node->update(%args))
        } ;
    };

    my $leaf_cb = sub ($scanner, $data_ref,$node,$element_name,$index, $leaf_object) {
        push @$data_ref, $leaf_object->update_from_file();
    };

    my $root = $self->config_root ;

    my @msgs ;
    Config::Model::ObjTreeScanner->new(
        node_content_hook => $hook,
        check => ($args{quiet} ? 'no' : 'yes'),
        leaf_cb => $leaf_cb,
        file_value_cb => $leaf_cb,
        dir_value_cb => $leaf_cb,
    )->scan_node( \@msgs, $root );

    return @msgs;
}

sub DEMOLISH {
    my $self = shift;
    $self->clear_write_back; # avoid reference loops