[SCM] Debian package checker branch, lab-refactor, updated. 2.5.3-57-g8a197df
The following commit has been merged in the lab-refactor branch:
commit 2e78f0037837bfd98ada6c51d9506e767e96958c
Author: Niels Thykier <niels@thykier.net>
Date: Sat Sep 24 10:16:48 2011 +0200
Split Processable into two classes
Lintian::Processable is now an abstract base class and the actual
implementation is deferred to Lintian::Processable::Package.
Signed-off-by: Niels Thykier <niels@thykier.net>
diff --git a/lib/Lintian/Processable.pm b/lib/Lintian/Processable.pm
index 3659fb7..6e9e10f 100644
--- a/lib/Lintian/Processable.pm
+++ b/lib/Lintian/Processable.pm
@@ -24,6 +24,8 @@ use base qw(Class::Accessor);
use strict;
use warnings;
+use Carp qw(croak);
+
use Util;
# Black listed characters - any match will be replaced with a _.
@@ -31,13 +33,14 @@ use constant EVIL_CHARACTERS => qr,[/&|;\$"'<>],o;
=head1 NAME
-Lintian::Processable -- An object that Lintian can process
+Lintian::Processable -- An (abstract) object that Lintian can process
=head1 SYNOPSIS
use Lintian::Processable;
-
- my $proc = Lintian::Processable->new('binary', 'lintian_2.5.0_all.deb');
+
+ # Instantiate via Lintian::Processable::Package
+ my $proc = Lintian::Processable::Package->new('binary', 'lintian_2.5.0_all.deb');
my $pkg_name = $proc->pkg_name();
my $pkg_version = $proc->pkg_version();
# etc.
@@ -64,18 +67,15 @@ defines this type of processable (e.g. the changes file).
=cut
sub new {
- my ($class, $pkg_type, $pkg_path) = @_;
+ my ($class, $pkg_type, @args) = @_;
my $self = {};
bless $self, $class;
$self->{pkg_type} = $pkg_type;
- $self->{pkg_path} = $pkg_path;
$self->{tainted} = 0;
- $self->_init ($pkg_type, $pkg_path);
+ $self->_init ($pkg_type, @args);
return $self;
}
-=pod
-
=item $proc->pkg_name()
@@ -90,6 +90,8 @@ Returns the version of the package.
Returns the path to the packaged version of actual package. This path
is used in case the data needs to be extracted from the package.
+Note: This may return the path to a symlink to the package.
+
=item $proc->pkg_type()
Returns the type of package (e.g. binary, source, udeb ...)
@@ -120,7 +122,7 @@ to less dangerous (but possibly invalid) values.
=cut
-Lintian::Processable->mk_ro_accessors (qw(pkg_name pkg_version pkg_src pkg_arch pkg_path pkg_type pkg_src_version group tainted));
+Lintian::Processable->mk_ro_accessors (qw(pkg_name pkg_version pkg_src pkg_arch pkg_path pkg_type pkg_src_version tainted));
=item $proc->info()
@@ -128,7 +130,7 @@ Returns L<Lintian::Collect|$info> element for this processable.
=cut
-sub info{
+sub info {
my ($self) = @_;
my $info = $self->{info};
if (! defined $info) {
@@ -153,89 +155,18 @@ sub clear_cache {
$lpkg->clear_cache if defined $lpkg;
}
-=item $proc->lab_pkg([$lpkg])
-
-Returns or sets the L<Lab::Package|$info> element for this processable.
-
-=cut
-
-Lintian::Processable->mk_accessors (qw(lab_pkg));
-
-=item $proc->set_group($group)
-
-Sets the L<Lintain::ProcessableGroup|group> of $proc.
-
-=cut
-
-sub set_group{
- my ($self, $group) = @_;
- $self->{group} = $group;
- return 1;
-}
-
-# internal initialization method.
-# reads values from fields etc.
-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};
- my $pkg_version = $dinfo->{version};
- my $pkg_src_version = $pkg_version;
- # 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)
- if ($pkg_src =~ m/(\S++)\s*\(([^\)]+)\)/o){
- $pkg_src = $1;
- $pkg_src_version = $2;
- }
- $self->{pkg_name} = $pkg_name;
- $self->{pkg_version} = $pkg_version;
- $self->{pkg_arch} = $dinfo->{architecture};
- $self->{pkg_src} = $pkg_src;
- $self->{pkg_src_version} = $pkg_src_version;
- } 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";
- my $pkg_version = $dinfo->{version};
- $self->{pkg_name} = $pkg_name;
- $self->{pkg_version} = $pkg_version;
- $self->{pkg_arch} = 'source';
- $self->{pkg_src} = $pkg_name; # it is own source pkg
- $self->{pkg_src_version} = $pkg_version;
- } 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 =~ m,.*/([^/]+)\.changes,);
- my $pkg_version = $cinfo->{version};
- $self->{pkg_name} = $pkg_name;
- $self->{pkg_version} = $pkg_version;
- $self->{pkg_src} = $cinfo->{source}//$pkg_name;
- $self->{pkg_src_version} = $pkg_version;
- $self->{pkg_arch} = $cinfo->{architecture};
- } else {
- fail "Unknown package type $pkg_type";
+sub _init {
+ my ($self, $pkg_type, @args) = @_;
+ my $type = ref $self;
+ if ($type && $type eq 'Lintian::Processable') {
+ croak 'Cannot create Lintian::Processable directly';
+ } elsif ($type) {
+ croak "$type has not overridden " . ${type} . '::_init';
}
- # make sure these are not undefined
- $self->{pkg_version} = '' unless (defined $self->{pkg_version});
- $self->{pkg_src_version} = '' unless (defined $self->{pkg_src_version});
- $self->{pkg_arch} = '' unless (defined $self->{pkg_arch});
- # make sure none of the fields can cause traversal.
- foreach my $field (qw(pkg_name pkg_version pkg_src pkg_src_version pkg_arch)) {
- if ($self->{$field} =~ m,${\EVIL_CHARACTERS},o){
- # None of these fields are allowed to contain a these
- # characters. This package is most likely crafted to
- # cause Path traversals or other "fun" things.
- $self->{tainted} = 1;
- $self->{$field} =~ s,${\EVIL_CHARACTERS},_,go;
- }
- }
- return 1;
+ croak 'Lintian::Processable::_init should not be called directly';
}
+
=back
=head1 AUTHOR
diff --git a/lib/Lintian/Processable.pm b/lib/Lintian/Processable/Package.pm
similarity index 61%
copy from lib/Lintian/Processable.pm
copy to lib/Lintian/Processable/Package.pm
index 3659fb7..0c510a2 100644
--- a/lib/Lintian/Processable.pm
+++ b/lib/Lintian/Processable/Package.pm
@@ -17,27 +17,29 @@
# MA 02110-1301, USA.
## Represents something Lintian can process (e.g. a deb, dsc or a changes)
-package Lintian::Processable;
+package Lintian::Processable::Package;
-use base qw(Class::Accessor);
+use base qw(Lintian::Processable Class::Accessor);
use strict;
use warnings;
-use Util;
+use Carp qw(croak);
+
+use Util qw(get_deb_info get_dsc_info);
# Black listed characters - any match will be replaced with a _.
use constant EVIL_CHARACTERS => qr,[/&|;\$"'<>],o;
=head1 NAME
-Lintian::Processable -- An object that Lintian can process
+Lintian::Processable::Package -- An object that Lintian can process
=head1 SYNOPSIS
use Lintian::Processable;
-
- my $proc = Lintian::Processable->new('binary', 'lintian_2.5.0_all.deb');
+
+ my $proc = Lintian::Processable::Package->new('binary', 'lintian_2.5.0_all.deb');
my $pkg_name = $proc->pkg_name();
my $pkg_version = $proc->pkg_version();
# etc.
@@ -53,7 +55,7 @@ together.
=over 4
-=item Lintian::Processable->new($pkg_type, $pkg_path)
+=item Lintian::Processable::Package->new($pkg_type, $pkg_path)
Creates a new processable of type $pkg_type, which must be one of:
'binary', 'udeb', 'source' or 'changes'
@@ -61,97 +63,12 @@ Creates a new processable of type $pkg_type, which must be one of:
$pkg_path should be the absolute path to the package file that
defines this type of processable (e.g. the changes file).
-=cut
-
-sub new {
- my ($class, $pkg_type, $pkg_path) = @_;
- my $self = {};
- bless $self, $class;
- $self->{pkg_type} = $pkg_type;
- $self->{pkg_path} = $pkg_path;
- $self->{tainted} = 0;
- $self->_init ($pkg_type, $pkg_path);
- return $self;
-}
-
-=pod
-
-
-=item $proc->pkg_name()
-
-Returns the package name.
-
-=item $proc->pkg_version()
-
-Returns the version of the package.
-
-=item $proc->pkg_path()
-
-Returns the path to the packaged version of actual package. This path
-is used in case the data needs to be extracted from the package.
-
-=item $proc->pkg_type()
-
-Returns the type of package (e.g. binary, source, udeb ...)
-
-=item $proc->pkg_arch()
-
-Returns the architecture(s) of the package. May return multiple values
-from source and changes processables.
-
-=item $proc->pkg_src()
-
-Returns the name of the source package.
-
-=item $proc->pkg_src_version()
-
-Returns the version of the source package.
-
-=item $proc->group()
+=item $proc->group([$group])
Returns the L<Lintain::ProcessableGroup|group> $proc is in,
if any. If the processable is not in a group, this returns C<undef>.
-=item $proc->tainted()
-
-Returns a truth value if one or more fields in this Processable is
-tainted. On a best effort basis tainted fields will be sanitized
-to less dangerous (but possibly invalid) values.
-
-=cut
-
-Lintian::Processable->mk_ro_accessors (qw(pkg_name pkg_version pkg_src pkg_arch pkg_path pkg_type pkg_src_version group tainted));
-
-=item $proc->info()
-
-Returns L<Lintian::Collect|$info> element for this processable.
-
-=cut
-
-sub info{
- my ($self) = @_;
- my $info = $self->{info};
- if (! defined $info) {
- my $lpkg = $self->lab_pkg();
- fail "Need a Lab package before creating a Lintian::Collect\n"
- unless defined $lpkg;
- return $lpkg->info;
- }
- return $info;
-}
-
-=item $proc->clear_cache()
-
-Discard the info element, so the memory used by it can be reclaimed.
-Mostly useful when checking a lot of packages (e.g. on lintian.d.o).
-
-=cut
-
-sub clear_cache {
- my ($self) = @_;
- my $lpkg = $self->lab_pkg;
- $lpkg->clear_cache if defined $lpkg;
-}
+Can also be used to set the group of this processable.
=item $proc->lab_pkg([$lpkg])
@@ -159,29 +76,20 @@ Returns or sets the L<Lab::Package|$info> element for this processable.
=cut
-Lintian::Processable->mk_accessors (qw(lab_pkg));
-
-=item $proc->set_group($group)
-
-Sets the L<Lintain::ProcessableGroup|group> of $proc.
-
-=cut
-
-sub set_group{
- my ($self, $group) = @_;
- $self->{group} = $group;
- return 1;
-}
+Lintian::Processable::Package->mk_accessors (qw(group lab_pkg));
# internal initialization method.
# reads values from fields etc.
-sub _init{
+sub _init {
my ($self, $pkg_type, $pkg_path) = @_;
+
+ $self->{pkg_path} = $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: $!";
+ croak "could not read control data in $pkg_path: $!";
my $pkg_name = $dinfo->{package} or
- fail "$pkg_path ($pkg_type) is missing mandatory \"Package\" field";
+ croak "$pkg_path ($pkg_type) is missing mandatory \"Package\" field";
my $pkg_src = $dinfo->{source};
my $pkg_version = $dinfo->{version};
my $pkg_src_version = $pkg_version;
@@ -199,8 +107,8 @@ sub _init{
$self->{pkg_src} = $pkg_src;
$self->{pkg_src_version} = $pkg_src_version;
} 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";
+ my $dinfo = get_dsc_info ($pkg_path) or croak "$pkg_path is not valid dsc file";
+ my $pkg_name = $dinfo->{source} or croak "$pkg_path is missing or has empty source field";
my $pkg_version = $dinfo->{version};
$self->{pkg_name} = $pkg_name;
$self->{pkg_version} = $pkg_version;
@@ -208,7 +116,7 @@ sub _init{
$self->{pkg_src} = $pkg_name; # it is own source pkg
$self->{pkg_src_version} = $pkg_version;
} elsif ($pkg_type eq 'changes'){
- my $cinfo = get_dsc_info ($pkg_path) or fail "$pkg_path is not a valid changes file";
+ my $cinfo = get_dsc_info ($pkg_path) or croak "$pkg_path is not a valid changes file";
my ($pkg_name) = ($pkg_path =~ m,.*/([^/]+)\.changes,);
my $pkg_version = $cinfo->{version};
$self->{pkg_name} = $pkg_name;
@@ -217,7 +125,7 @@ sub _init{
$self->{pkg_src_version} = $pkg_version;
$self->{pkg_arch} = $cinfo->{architecture};
} else {
- fail "Unknown package type $pkg_type";
+ croak "Unknown package type $pkg_type";
}
# make sure these are not undefined
$self->{pkg_version} = '' unless (defined $self->{pkg_version});
@@ -236,6 +144,7 @@ sub _init{
return 1;
}
+
=back
=head1 AUTHOR
@@ -246,6 +155,8 @@ Originally written by Niels Thykier <niels@thykier.net> for Lintian.
lintian(1)
+L<Lintian::Processable>
+
L<Lintain::ProcessableGroup>
=cut
diff --git a/lib/Lintian/ProcessableGroup.pm b/lib/Lintian/ProcessableGroup.pm
index e3c9a7a..5d4cea6 100644
--- a/lib/Lintian/ProcessableGroup.pm
+++ b/lib/Lintian/ProcessableGroup.pm
@@ -137,7 +137,7 @@ This is short hand for:
sub add_new_processable {
my ($self, $pkg_type, $pkg_path) = @_;
return $self->add_processable(
- Lintian::Processable->new($pkg_type, $pkg_path));
+ Lintian::Processable::Package->new($pkg_type, $pkg_path));
}
=item $group->add_processable($proc)
@@ -178,7 +178,7 @@ sub add_processable{
return 0 if (exists $phash->{"${name}_${version}_${arch}"});
$phash->{"${name}_${version}_${arch}"} = $processable;
}
- $processable->set_group($self);
+ $processable->group($self);
return 1;
}
diff --git a/lib/Lintian/ProcessablePool.pm b/lib/Lintian/ProcessablePool.pm
index 2a7271f..c03b274 100644
--- a/lib/Lintian/ProcessablePool.pm
+++ b/lib/Lintian/ProcessablePool.pm
@@ -25,7 +25,7 @@ use warnings;
use Cwd();
use Util;
-use Lintian::Processable;
+use Lintian::Processable::Package;
use Lintian::ProcessableGroup;
=head1 NAME
@@ -91,7 +91,7 @@ sub add_file {
}
# Just insert these for now.
$tmap = $self->{$pkg_type};
- $proc = Lintian::Processable->new($pkg_type, $pkg_path);
+ $proc = Lintian::Processable::Package->new($pkg_type, $pkg_path);
if ($proc->tainted()){
warn(sprintf("warning: tainted %1\$s package '%2\$s', skipping\n",
$pkg_type, $proc->pkg_name()));
--
Debian package checker
Reply to: