libconfig-model-dpkg-perl 2.059 / usr / share / perl5 / Config / Model / Backend / Dpkg.pm

package Config::Model::Backend::Dpkg;

use Carp;
use Mouse;
use Config::Model::Exception;
use UNIVERSAL;
use File::Path;
use Log::Log4perl qw(get_logger :levels);

extends 'Config::Model::Backend::PlainFile';

my $logger = get_logger("Backend::Dpkg::Root");

sub read_hash {
    my ( $self, $obj, $elt, $file, $check, $args ) = @_;

    if ( $elt eq 'patches' ) {
        my $patch_dir = $args->{root} . $args->{config_dir} . "patches";
        $logger->info("Checking patches directory ($patch_dir)");

        $self->read_patch_series( $obj, $check, $patch_dir, $args );
    }
    else {
        $self->SUPER::read_hash(@_);
    }
}

sub read_patch_series {
    my ( $self, $hash, $check, $patch_dir, $args ) = @_;

    my $series_files = "$patch_dir/series";

    return unless -d $patch_dir;
    return unless -e $series_files;

    $logger->info("Opening file $series_files");
    my $ser_io = IO::File->new($series_files);

    unless ( defined $ser_io ) {
        my $msg = "Dpkg::Patch error, cannot read $series_files:$!";
        Config::Model::Exception::User->throw( message => $msg )
          if $check eq 'yes';
        $logger->error($msg) if $check eq 'skip';
    }

    # trigger element creation to read patch file_path
    foreach my $pname ( $ser_io->getlines ) {
        chomp $pname;
		$pname =~ s/#.*//; # skip comment
        next unless $pname =~ /\w/;    # skip empty lines
        my $obj = $hash->fetch_with_id($pname);
        eval { $obj->init; };
        my $e;
        if ($e = Exception::Class->caught('Config::Model::Exception::Syntax')) {
            if ( $args->{check} eq 'yes' ) {
                my $msg = $e ->message. ". Use -force option to override" ;
                ref($e) -> throw(message => $msg);
            }
            else {
                warn "Warning: Ignoring patch $pname: ", $e->message,"\n";
            }
            $hash->delete($pname);
        }
        elsif ( $e = Exception::Class->caught() ) {
            ref $e ? $e->rethrow : die $e;
        }
        elsif ($logger->is_info) {
            my $location = $obj->name;
            $logger->info("found patch $pname, stored in $location ($obj)");
        }
    }

    $ser_io->close;
}

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

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

    my $check = $args{check} || 'yes';
    my $dir = $args{root} . $args{config_dir};
    mkpath( $dir, { mode => 0755 } ) unless -d $dir;
    my $node = $args{object};
    $logger->debug( "Dpkg write called on node ", $node->name );

    # write data from leaf element from the node
    foreach my $elt ( $node->get_element_name() ) {
        my $file = $dir . $elt;

        my $obj = $args{object}->fetch_element( name => $elt );
        my $type = $obj->get_type;
        my @v;

        if ( $type eq 'leaf' ) {
            my $lv = $obj->fetch( check => $args{check} );
            if ( defined $lv ) {
                $lv .= "\n" unless $obj->value_type eq 'string';
                push @v, $lv;
            }
        }
        elsif ( $type eq 'list' ) {
            @v = map { "$_\n" } $obj->fetch_all_values;
        }
        else {
            $logger->debug("Dpkg write skipped $type $elt");
        }

        if (@v) {
            $logger->trace("Dpkg write opening $file to write");
            my $fh = new IO::File;
            $fh->open( $file, '>' ) or die "Cannot open $file:$!";
            $fh->binmode(":utf8");
            $fh->print(@v);
            $fh->close;
        }
    }

    return 1;
}

no Mouse;
__PACKAGE__->meta->make_immutable;

1;

__END__

=head1 NAME

Config::Model::Backend::Dpkg - Read and write config as plain file

=head1 SYNOPSIS

 use Config::Model;
 use Log::Log4perl qw(:easy);
 Log::Log4perl->easy_init($WARN);

 my $model = Config::Model->new;

 my $inst = $model->create_config_class(
    name => "WithDpkg",
    element => [ 
        [qw/source new/] => { qw/type leaf value_type uniline/ },
    ],
    read_config  => [ 
        { 
            backend => 'plain_file', 
            config_dir => '/tmp',
        },
    ],
 );
 
 my $inst = $model->instance(root_class_name => 'WithDpkg' );
 my $root = $inst->config_root ;

 $root->load('source=foo new=yes' );

 $inst->write_back ;

Now C</tmp> directory will contain 2 files: C<source> and C<new> 
with C<foo> and C<yes> inside.

=head1 DESCRIPTION

This module is used directly by L<Config::Model> to read or write the
content of a configuration tree written in several files. 
Each element of the node is written in a plain file.

This module supports currently only leaf and list elements.  
In the case of C<list> element, each line of the file is a value of the list.


=head1 CONSTRUCTOR

=head2 new ( node => $node_obj, name => 'plain_file' ) ;

Inherited from L<Config::Model::Backend::Any>. The constructor will be
called by L<Config::Model::AutoRead>.

=head2 read ( io_handle => ... )

Of all parameters passed to this read call-back, only C<io_handle> is
used. This parameter must be L<IO::File> object already opened for
read. 

It can also be undef. In this case, C<read()> will return 0.

When a file is read,  C<read()> will return 1.

=head2 write ( io_handle => ... )

Of all parameters passed to this write call-back, only C<io_handle> is
used. This parameter must be L<IO::File> object already opened for
write. 

C<write()> will return 1.

=head1 AUTHOR

Dominique Dumont, (ddumont at cpan dot org)

=head1 SEE ALSO

L<Config::Model>, 
L<Config::Model::BackendMgr>,
L<Config::Model::Backend::Any>, 

=cut