package Config::Model::Backend::Dpkg::Control ;
use strict;
use warnings;

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

extends 'Config::Model::Backend::Any';

with 'Config::Model::Backend::DpkgSyntax';
with 'Config::Model::Backend::DpkgStoreRole';

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

use Config::Model::Dpkg::Dependency;

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

sub suffix { return '' ; }

sub read {
    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' 
    # io_handle  => $io           # IO::File object
    # check      => yes|no|skip  

    return 0 unless defined $args{io_handle} ;

    $logger->info("Parsing $args{file_path}");
    # load dpkgctrl file
    my $c = $self -> parse_dpkg_file ($args{file_path}, $args{io_handle}, $args{check}, 1 ) ;

    # fix Debian #735000: ask for infos for all packages not in cache in one go.
    $self->fill_package_cache ($c);

    my $root = $args{object} ;
    my $check = $args{check} ;
    my $file;
    
    $logger->debug("Reading control source info");

    # first section is source package, following sections are binary package
    my $node = $root->fetch_element(name => 'source', check => $check) ;
    $self->read_sections ($node, shift @$c, shift @$c, $check);

    $logger->debug("Reading binary package names");
    # we assume that package name is the first item in the section data

    while (@$c ) {
        my ($section_line,$section) = splice @$c,0,2 ;
        my $package_name;
        foreach (my $i = 0; $i < $#$section; $i += 2) {
            next unless $section->[$i] =~ /^package$/i;
            $package_name = $section->[ $i+1 ][0][0];
            splice @$section,$i,2 ;
            last ;
        }
        
        if (not defined $package_name) {
            my $msg = "Cannot find package_name in section beginning at line $section_line";
            Config::Model::Exception::Syntax
                  -> throw (object => $root,  error => $msg, parsed_line => $section_line) ;
        }

        $node = $root->grab("binary:$package_name") ;
        $self->read_sections ($node, $section_line, $section, $args{check});
    }
    return 1 ;
}

sub fill_package_cache ($self, $c) {

    # scan data to find package name and query madison for info for all packages in a single call
    my %packages; # use a hash to eliminate duplicates
    foreach my $s (@$c) {
        next unless ref $s eq 'ARRAY' ;
        my %section = @$s ; # don't care about order

        foreach my $found (keys %section) {
            if ($found =~ /Depends|Suggests|Recommends|Enhances|Breaks|Conflicts|Replaces/) {
                # $section{found} array is [ [ dep, line_nb, altered_value , comment ], ..]
                map { $packages{$_} = 1 }
                    grep { not /\$/ } # skip debhelper variables
                    map {
                        chomp;
                        s/\[.*\]//g; # remove arch details
                        s/<.*>//;    # remove build profile
                        s/\(.*\)//;  # remove version details
                        s/\s//g;
                        s/,\s*$//;   # remove trailing comma
                        $_;
                    }
                    map { split /\s*[,|]\s*/ , $_->[0] } # extract dependency info from array ref
                    grep { ref $_ } # skip emtpy data
                    $section{$found}->@*;
            }
        }
    }
    my @pkgs = keys %packages;
    Config::Model::Dpkg::Dependency::cache_info_from_madison ($self->node->instance,@pkgs);
}

sub read_sections {
    my $self = shift ;
    my $node = shift;
    my $section_line = shift ;
    my $section = shift;
    my $check = shift || 'yes';

    my %sections ;
    for (my $i=0; $i < @$section ; $i += 2 ) {
        my $key = $section->[$i];
        my $lc_key = lc($key); # key are not key sensitive
        $sections{$lc_key} = [ $key , $section->[$i+1] ]; 
    }

    foreach my $key ($node->get_element_name) {
        my $ref = delete $sections{lc($key)} ;
        next unless defined $ref ;
        $self->store_section_element_in_tree ($node,$check, @$ref);
    }
    
    # leftover sections should be either accepted or rejected
    foreach my $lc_key (keys %sections) {
        my $ref = delete $sections{$lc_key} ;
        $self->store_section_element_in_tree ($node,$check, @$ref);
    }
}

#
# New subroutine "store_section_element_in_tree" extracted - Mon Jul  4 13:35:50 2011.
#
sub store_section_element_in_tree {
    my $self  = shift;
    my $node  = shift;
    my $check = shift;
    my $key   = shift;
    my $v_ref = shift;

    $logger->info( "reading key '$key' from control file (for node "
          . $node->location
          . ")" );

    # control parameters are case insensitive. Falling back on $key
    # means $key is unknown. fetch_element will trigger a meaningful
    # error message
    my $found = $node->find_element( $key, case => 'any' ) || $key;

    # v_ref is a list of ($value, $line_nb ,$note,@comment) = @$v_ref;

    my $elt_obj = $node->fetch_element( name => $found, check => $check );
    my $type = $node->element_type($found);

    if ( $type eq 'list' ) {
        $self->store_section_list_element ( $logger,  $elt_obj, $check, $v_ref);
    }
    elsif ($found eq 'Description' and $elt_obj) {
        my ($synopsis_ref, @desc_ref) = $v_ref->@*;
        $self->store_section_leaf_element ( $logger, $node->fetch_element('Synopsis'), $check, [$synopsis_ref]);
        $self->store_section_leaf_element ( $logger, $node->fetch_element('Description'), $check, \@desc_ref);
    }
    elsif ($elt_obj ) {
        $self->store_section_leaf_element ( $logger, $elt_obj, $check, $v_ref);
    }
    else {
        # try anyway to trigger an error message
        my $unexpected_obj = $node->fetch_element($key);
        $self->store_section_leaf_element ( $logger, $unexpected_obj, $check, $v_ref);
    }
}


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' 
    # io_handle  => $io           # IO::File object

    croak "Undefined file handle to write"
      unless defined $args{io_handle} ;

    my $node = $args{object} ;
    my $ioh  = $args{io_handle} ;
    my @sections = [ $self-> package_spec($node->fetch_element('source')) ];

    my $binary_hash = $node->fetch_element('binary') ;
    foreach my $binary_name ( $binary_hash -> fetch_all_indexes ) {
        my $ref = [ Package => $binary_name ,
                    $self->package_spec($binary_hash->fetch_with_id($binary_name)) ];
        
        push @sections, $ref ;
    }

    $self->write_dpkg_file($ioh, \@sections,",\n" ) ;
    
    return 1;
}

sub package_spec {
    my ( $self, $node ) = @_ ;

    my @section ;
    my $description_ref ;
    foreach my $elt ($node->get_element_name ) {
        my $type = $node->element_type($elt) ;
        my $elt_obj = $node->fetch_element($elt) ;

        my $c = $elt_obj->annotation ;
        push @section, map {'# '.$_} split /\n/,$c if $c ;

        if ($type eq 'hash') {
            die "package_spec: unexpected hash type in ".$node->name." element $elt\n" ;
        }
        elsif ($type eq 'list') {
            my @v;
            my @indexes = $elt_obj->fetch_all_indexes;

            foreach my $idx (@indexes) {
                my $value_obj = $elt_obj->fetch_with_id($idx);
                my $value = $value_obj->fetch;
                next unless defined $value;

                my $note = $value_obj->annotation;
                my $comment = $note ? join ("\n",map {'# '.$_} split /\n/,$note ) : undef;
                push @v, $comment ? [ $value, $comment ] : $value;
            }
            push @section, $elt , \@v if @v;
        }
        elsif ($elt eq 'Synopsis') {
            my $v = $node->fetch_element_value($elt) ;
            push @section, 'Description' , $v ; # mandatory field
            $description_ref = \$section[$#section] ;
        }
        elsif ($elt eq 'Description') {
            $$description_ref .= "\n".$node->fetch_element_value($elt) ; # mandatory field
        }
        else {
            my $v = $node->fetch_element_value($elt) ;
            push @section, $elt , $v if $v ;
        }
    }
    return @section ;
}


1;

__END__

=head1 NAME

Config::Model::Backend::Dpkg::Control - Read and write Debian Dpkg control information

=head1 SYNOPSIS

No synopsis. This class is dedicated to configuration class C<Dpkg::Control>

=head1 DESCRIPTION

This module is used directly by L<Config::Model> to read or write the
content of Debian C<control> file.

All C<control> files keyword are read in a case-insensitive manner.

=head1 CONSTRUCTOR

=head2 new ( node => $node_obj, name => 'Dpkg::Control' ) ;

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::AutoRead>, 
L<Config::Model::Backend::Any>, 

=cut
