[SCM] Debian package checker branch, master, updated. 2.5.0-rc2-122-g12888e8
The following commit has been merged in the master branch:
commit e9d1602749f5c790ee35b13079e56a58193c5bfa
Author: Niels Thykier <niels@thykier.net>
Date: Sun Feb 20 17:59:22 2011 +0100
Add new processable modules to group packages + prototype script
diff --git a/lib/Lintian/Processable.pm b/lib/Lintian/Processable.pm
new file mode 100644
index 0000000..91c2e66
--- /dev/null
+++ b/lib/Lintian/Processable.pm
@@ -0,0 +1,89 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+## Represents something Lintian can process (e.g. a deb, dsc or a changes)
+package Lintian::Processable;
+
+use base qw(Class::Accessor);
+
+use strict;
+use warnings;
+
+use Util;
+
+sub new {
+ my ($class, $pkg_type, $pkg_path) = @_;
+ my $self = {};
+ bless $self, $class;
+ $self->{pkg_type} = $pkg_type;
+ $self->{pkg_path} = $pkg_path;
+ $self->_init ($pkg_type, $pkg_path);
+ return $self;
+}
+
+Lintian::Processable->mk_accessors (qw(pkg_name pkg_version pkg_src pkg_arch pkg_path pkg_type group));
+
+
+sub set_group{
+ my ($self, $group) = @_;
+ $self->{group} = $group;
+ return 1;
+}
+
+sub _init{
+ my ($self, $pkg_type, $pkg_path) = @_;
+ if ($pkg_type eq 'binary' or $pkg_type eq 'udeb'){
+ my $dinfo = get_deb_info ($pkg_path) or
+ fail "could not read control data in $pkg_path: $!";
+ my $pkg_name = $dinfo->{package} or
+ fail "$pkg_path ($pkg_type) is missing mandatory \"Package\" field";
+ my $pkg_src = $dinfo->{source};
+ # Source may be left out if it is the same as $pkg_name
+ $pkg_src = $pkg_name unless ( defined $pkg_src && length $pkg_src );
+
+ # Source may contain the version (in parentheses)
+ $pkg_src =~ s/\s*\(.+$//o;
+ $self->{pkg_name} = $pkg_name;
+ $self->{pkg_version} = $dinfo->{version};
+ $self->{pkg_arch} = $dinfo->{architecture};
+ $self->{pkg_src} = $pkg_src;
+ } elsif ($pkg_type eq 'source'){
+ my $dinfo = get_dsc_info ($pkg_path) or fail "$pkg_path is not valid dsc file";
+ my $pkg_name = $dinfo->{source} or fail "$pkg_path is missing or has empty source field";
+ $self->{pkg_name} = $pkg_name;
+ $self->{pkg_version} = $dinfo->{version};
+ $self->{pkg_arch} = 'source';
+ $self->{pkg_src} = $pkg_name; # it is own source pkg
+ } elsif ($pkg_type eq 'changes'){
+ my $cinfo = get_dsc_info ($pkg_path) or fail "$pkg_path is not a valid changes file";
+ my $pkg_name = $pkg_path;
+ $pkg_name =~ s,.*/([^/]+)\.changes$,$1,;
+ $self->{pkg_name} = $pkg_name;
+ $self->{pkg_version} = $cinfo->{version};
+ $self->{pkg_src} = $cinfo->{source}//$pkg_name;
+ $self->{pkg_arch} = $cinfo->{architecture};
+ } else {
+ fail "Unknown package type $pkg_type";
+ }
+ # make sure these are not undefined
+ $self->{pkg_version} = '' unless (defined $self->{pkg_version});
+ $self->{pkg_arch} = '' unless (defined $self->{pkg_arch});
+ return 1;
+}
+
+1;
diff --git a/lib/Lintian/ProcessableGroup.pm b/lib/Lintian/ProcessableGroup.pm
new file mode 100644
index 0000000..f8d88cb
--- /dev/null
+++ b/lib/Lintian/ProcessableGroup.pm
@@ -0,0 +1,147 @@
+# Copyright (C) 2011 Niels Thykier <niels@thykier.net>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, you can find it on the World Wide
+# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
+# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
+# MA 02110-1301, USA.
+
+## Represents a group of 'Lintian::Processable's
+package Lintian::ProcessableGroup;
+
+use strict;
+use warnings;
+
+use Util;
+use Lintian::Processable;
+
+sub new {
+ my ($class, $changes) = @_;
+ my $self = {};
+ bless $self, $class;
+ $self->_init_group_from_changes($changes)
+ if defined $changes;
+ return $self;
+}
+
+sub _init_group_from_changes {
+ my ($self, $changes) = @_;
+ my ($group, $pch, $cinfo, $cdir);
+ fail "$changes does not exist" unless -e $changes;
+ $cinfo = get_dsc_info ($changes) or
+ fail "$changes is not a valid changes file";
+ $self->add_new_processable('changes', $changes);
+ $cdir = $changes;
+ $cdir =~ s,(.+)/[^/]+$,$1,;
+ foreach my $line (split (/\n/o, $cinfo->{'files'}//'')) {
+ my ($file, $proc, $pkg_type);
+ next unless defined $line;
+ chomp($line);
+ $line =~ s/^\s++//o;
+ next if $line eq '';
+ # Ignore files that may lead to path traversal issues.
+
+ # We do not need (in order) md5sum, size, section or priority
+ # - just the file name please.
+ (undef, undef, undef, undef, $file) = split(/\s+/o, $line);
+
+ next if $file =~ m,/,;
+
+ if (not -f "$cdir/$file") {
+ print STDERR "$cdir/$file does not exist, exiting\n";
+ exit 2;
+ }
+
+ if ($file =~ /\.deb$/o) {
+ $pkg_type = 'binary';
+ } elsif ($file =~ /\.udeb$/o){
+ $pkg_type = 'udeb';
+ } elsif ($file =~ /\.dsc$/o){
+ $pkg_type = 'source';
+ } else {
+ # Some file we do not care about (at least not here).
+ next;
+ }
+
+ $self->add_new_processable($pkg_type, "$cdir/$file");
+
+ }
+ return 1;
+}
+
+# Short hand for:
+# $self->add_processable(Lintian::Processable->new($pkg_type, $pkg_path))
+sub add_new_processable {
+ my ($self, $pkg_type, $pkg_path) = @_;
+ return $self->add_processable(
+ Lintian::Processable->new($pkg_type, $pkg_path));
+}
+
+sub add_processable{
+ my ($self, $processable) = @_;
+ my $pkg_type = $processable->pkg_type();
+
+ if ($pkg_type eq 'changes'){
+ fail 'Cannot add another changes file' if (exists $self->{changes});
+ $self->{changes} = $processable;
+ } elsif ($pkg_type eq 'source'){
+ fail 'Cannot add another source package' if (exists $self->{source});
+ $self->{source} = $processable;
+ } else {
+ my $phash;
+ my $name = $processable->pkg_name;
+ my $version = $processable->pkg_version;
+ my $arch = $processable->pkg_arch;
+ fail "Unknown type $pkg_type"
+ unless ($pkg_type eq 'binary' or $pkg_type eq 'udeb');
+ $phash = $self->{$pkg_type};
+ if (!defined $phash){
+ $phash = {};
+ $self->{$pkg_type} = $phash;
+ }
+ # duplicate ?
+ return 0 if (exists $phash->{"${name}_${version}_${arch}"});
+ $phash->{"${name}_${version}_${arch}"} = $processable;
+ }
+ $processable->set_group($self);
+ return 1;
+}
+
+sub get_processables {
+ my ($self) = @_;
+ my @result = ();
+ # We return changes, dsc, debs and udebs in that order,
+ # because that is the order lintian used to process a changes
+ # file (modulo debs<->udebs ordering).
+ #
+ # Also correctness of other parts rely on this order.
+ foreach my $type (qw(changes source)){
+ push @result, $self->{$type} if (exists $self->{$type});
+ }
+ foreach my $type (qw(binary udeb)){
+ push @result, values %{$self->{$type}} if (exists $self->{$type});
+ }
+ return wantarray ? @result : \@result;
+}
+
+sub get_source_processable {
+ my ($self) = @_;
+ return $self->{source};
+}
+
+sub get_changes_processable {
+ my ($self) = @_;
+ return $self->{changes};
+}
+
+1;
diff --git a/private/processable-prototype.pl b/private/processable-prototype.pl
new file mode 100755
index 0000000..687b0cf
--- /dev/null
+++ b/private/processable-prototype.pl
@@ -0,0 +1,146 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+BEGIN {
+ # determine LINTIAN_ROOT
+ my $LINTIAN_ROOT = $ENV{'LINTIAN_ROOT'};
+ $LINTIAN_ROOT = '.'
+ if (defined $LINTIAN_ROOT and not length $LINTIAN_ROOT);
+ $LINTIAN_ROOT = '/usr/share/lintian' unless ($LINTIAN_ROOT);
+ $ENV{'LINTIAN_ROOT'} = $LINTIAN_ROOT;
+}
+
+use lib "$ENV{'LINTIAN_ROOT'}/lib";
+use Lintian::Processable;
+use Lintian::ProcessableGroup;
+use Util;
+use Cwd();
+
+my $debug = $ENV{DEBUG}//0;
+my $cwd = Cwd::cwd();
+my %group_map = ();
+my %type_map = (
+ 'changes' => {},
+ 'binary' => {},
+ 'source' => {},
+ 'udeb' => {},
+);
+
+FILE:
+foreach my $file (@ARGV) {
+ my $type;
+ my $proc;
+ my $tmap;
+ $file = "$cwd/$file" unless ($file =~ m@^/@o);
+
+ if ($file =~ m/\.changes$/o){
+ my $group = Lintian::ProcessableGroup->new($file);
+ my $src_proc;
+ # Correctness depends on the documented order of
+ # get_processables
+ foreach my $gmember (@{$group->get_processables()}){
+ my $mtype = $gmember->pkg_type();
+ my $mname = $gmember->pkg_name();
+ my $tmap = $type_map{$mtype};
+ if (exists $tmap->{$mname}){
+ if ($mtype eq 'changes'){
+ # Skip this changes file - we have seen it before
+ warning ("Skipping $mname ($mtype) - duplicate");
+ next FILE;
+ } else {
+ # dump the old file - most likely the one from the
+ # changes file will provide the best results if they
+ # are not identical.
+ warning ("Ignoring previously added $mname ($mtype) - " .
+ "duplicate of file from $file");
+ }
+ }
+ $tmap->{$mname} = $gmember;
+ }
+ $src_proc = $group->get_source_processable();
+ $src_proc = $group->get_changes_processable() unless defined $src_proc;
+ fail "$file has no src_proc ($group)" unless defined $src_proc;
+ # There are no clashes in sane packages because $src->pkg_src
+ # eq $chn->pkg_src except for crafted/incorrect files.
+ #
+ # ... and for crafted packages we have more to worry about
+ # than suboptimal check accuracy.
+ $group_map{$src_proc->pkg_src()} = $group;
+ next;
+ }
+
+ if ($file =~ m/\.deb$/o){
+ $type = 'binary';
+ } elsif ($file =~ m/\.udeb$/o){
+ $type = 'udeb';
+ } elsif ($file =~ m/\.dsc$/o){
+ $type = 'source';
+ } else {
+ fail "cannot handle $file";
+ }
+ $proc = Lintian::Processable->new($type, $file);
+ $tmap = $type_map{$type};
+ if (exists $tmap->{$proc->pkg_name()}){
+ warning ("Skipping " . $proc->pkg_name() . " ($type) - duplicate package");
+ } else {
+ $tmap->{$proc->pkg_name()} = $proc;
+ }
+}
+
+
+# create a proc-group for each of the remaining source packages.
+foreach my $source (values %{ $type_map{'source'} }) {
+ my $group;
+ next if defined $source->group();
+ print STDERR "Creating group for " . $source->pkg_src(), "\n";
+ $group = Lintian::ProcessableGroup->new();
+ $group->add_processable($source);
+ $group_map{$source->pkg_src()} = $group;
+}
+
+foreach my $bin (values %{ $type_map{'binary'} }, values %{ $type_map{'udeb'} }){
+ my $src_name = $bin->pkg_src();
+ my $group = $group_map{$src_name};
+ if (! defined $group){
+ # Create a new group based on the name of the source package
+ # - perhaps we will get more binaries from the same source.
+ $group = Lintian::ProcessableGroup->new();
+ $group_map{$src_name} = $group;
+ }
+ $group->add_processable($bin);
+}
+
+foreach my $gname (sort keys %group_map){
+ my $group = $group_map{$gname};
+ print "Group \"$gname\" consists of [",
+ join(', ', map { stringify_proc($_) } @{$group->get_processables()}),
+ "]\n";
+}
+
+exit 0;
+
+
+## subs
+
+sub stringify_proc {
+ my ($proc) = @_;
+ my $pkg_name = $proc->pkg_name();
+ my $pkg_type = $proc->pkg_type();
+ my $pkg_arch = $proc->pkg_arch();
+ my $pkg_version = $proc->pkg_version();
+ return "${pkg_name} ($pkg_type)";
+}
+
+sub debug {
+ my ($level, $msg) = @_;
+ print "$msg\n" if $level >= $debug;
+}
+
+
+sub warning {
+ my ($msg) = @_;
+ print STDERR "$msg\n";
+}
+
--
Debian package checker
Reply to: