File Coverage

blib/lib/Parse/Debian/PackageDesc.pm

Criterion	Covered	Total	%
statement	83	85	97.6
branch	6	8	75.0
condition	2	2	100.0
subroutine	31	33	93.9
pod	18	26	69.2
total	140	154	90.9

package Parse::Debian::PackageDesc;

use strict;
use warnings;
our $VERSION = 0.15;
use 5.00800;

use Carp    qw(carp croak); # NEVER USE warn OR die !
use English qw(-no_match_vars);
use File::Basename;
use Encode;


sub new {
    my ($class, $path, %user_opts) = @_;

    my $self = bless {
                        path    => $path,
                        options => { %user_opts },
                     }, $class;
    if (-r $path) {
        open F, $path;
        $self->{contents} = decode('utf-8', join("", ));
        close F;
    }
    else {
        croak "Can't read file '$path'";
    }

    return $self;
}

sub path { $_[0]->{path} }

sub get_line_attr {
    my ($self, $attr) = @_;

    $self->{contents} =~ /^$attr: (.*)/m;
    return $1;
}

sub get_block_attr {
    my ($self, $attr) = @_;

    # Collect lines that start with space
    $self->{contents} =~ /^$attr:\s*\n(( [^\n]+\n)+)/m;
    return $1;
}

sub date {
    $_[0]->get_line_attr("Date");
}

sub name {
    $_[0]->source;
}

# This is special because we have to cover the binNMU case (we get lines like:
# "Source: libparse-debian-packagedesc-perl (0.12-1)" but we have to return
# just "libparse-debian-packagedesc-perl")
sub source {
    my $source_value = $_[0]->get_line_attr("Source");
    $source_value =~ s/ .*//;
    return $source_value;
}

sub architecture {
    split(/\s+/, $_[0]->get_line_attr("Architecture"));
}

sub version {
    $_[0]->get_line_attr("Version");
}

sub extract_upstream_version {
    my ($pkg, $version) = @_;

    $version =~ s/-[a-z0-9+.~]+$//i;
    return $version
}

sub upstream_version {
    my ($self) = @_;
    return __PACKAGE__->extract_upstream_version($self->version);
}

sub extract_debian_revision {
    my ($pkg, $version) = @_;

    $version =~ /-([a-z0-9+.~]+)$/i;
    return $1 || "";
}

sub debian_revision {
    my ($self) = @_;
    return __PACKAGE__->extract_debian_revision($self->version);
}

sub distribution {
    $_[0]->get_line_attr("Distribution");
}

sub urgency {
    $_[0]->get_line_attr("Urgency");
}

sub maintainer {
    $_[0]->get_line_attr("Maintainer");
}

sub changed_by {
    $_[0]->get_line_attr("Changed-By");
}

sub binary_packages {
    split(/\s/, $_[0]->get_line_attr("Binary"));
}

sub changes {
    $_[0]->get_block_attr("Changes");
}

sub files {
    my ($self) = @_;

    my $files = $self->get_block_attr("Files");
    return map { my @fields = split(/\s+/, $_); $fields[5] }
               split(/\n/, $files);
}

sub binary_package_files {
    my ($self) = @_;

    grep { $_ =~ /\.deb$/ } $self->files;
}

sub execute_gpg_verify {
    my ($self) = @_;

    my $options = defined $self->{options}->{gpg_homedir} ?
                    "--homedir '$self->{options}->{gpg_homedir}'" :
                    "";
    my $gpg_cmd_line = "LC_ALL=C gpg $options --verify ".$self->path." 2>&1";
    $self->{gpg_verify_output} = `$gpg_cmd_line`;
    $self->{gpg_verify_status} = $?;
}

sub gpg_verify_status {
    my ($self) = @_;

    if (!$self->{gpg_verify_status}) {
        $self->execute_gpg_verify;
    }
    return $self->{gpg_verify_status};
}

sub gpg_verify_output {
    my ($self) = @_;

    if (!$self->{gpg_verify_output}) {
        $self->execute_gpg_verify;
    }
    return $self->{gpg_verify_output};
}

sub correct_signature {
    my ($self) = @_;
    return ($self->gpg_verify_status == 0);
}

sub signature_id {
    my ($self) = @_;
    $self->gpg_verify_output =~ /^gpg: Signature.*ID (\w+)$/m;
    return $1;
}

1;

__END__