[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 e99f953528817448ddd2e303f57fcfb8517c7131
Author: Niels Thykier <niels@thykier.net>
Date: Sat Sep 24 10:20:39 2011 +0200
Basic Lintian::Lab::Entry implementation
Signed-off-by: Niels Thykier <niels@thykier.net>
diff --git a/lib/Lintian/Lab.pm b/lib/Lintian/Lab.pm
index 91859c9..467ed29 100644
--- a/lib/Lintian/Lab.pm
+++ b/lib/Lintian/Lab.pm
@@ -33,14 +33,16 @@ use File::Temp qw(tempdir); # For temporary labs
use Scalar::Util qw(blessed);
+
+use constant {
# Lab format Version Number increased whenever incompatible changes
# are done to the lab so that all packages are re-unpacked
-use constant LAB_FORMAT => 10.1;
-
+ LAB_FORMAT => 10.1,
# Constants to avoid semantic errors due to typos in the $lab->{'mode'}
# field values.
-use constant LAB_MODE_STATIC => 'static';
-use constant LAB_MODE_TEMP => 'temporary';
+ LAB_MODE_STATIC => 'static',
+ LAB_MODE_TEMP => 'temporary',
+};
# A private table of suported types.
my %SUPPORTED_TYPES = (
@@ -57,10 +59,10 @@ BEGIN {
@EXPORT = ();
%EXPORT_TAGS = (
constants => [qw(LAB_FORMAT)],
- );
+ );
@EXPORT_OK = (
- @{$EXPORT_TAGS{constants}}
- );
+ @{ $EXPORT_TAGS{constants} }
+ );
};
use Util qw(delete_dir); # Used by $lab->remove_lab
@@ -79,7 +81,7 @@ Lintian::Lab -- Interface to the Lintian Lab
if (!$lab->lab_exists) {
$lab->create_lab;
}
- $lab->open_lab
+ $lab->open_lab;
# Fetch a package from the lab
my $pkg = $lab->get_package ('lintian', 'binary', '2.5.4', 'all');
@@ -107,7 +109,7 @@ sub new {
my $mode = LAB_MODE_TEMP;
if ($dir) {
$absdir = Cwd::abs_path($dir);
- croak "Cannot resolve $dir: $!" unless $absdir;
+ croak ("Cannot resolve $dir: $!") unless $absdir;
$mode = LAB_MODE_STATIC;
} else {
$absdir = ''; #Ensure it is defined.
@@ -116,11 +118,12 @@ sub new {
# Must be absolute (frontend/lintian depends on it)
# - also $self->dir promises this
# - it may be the empty string (see $self->dir)
- 'dir' => $absdir,
- 'state' => {},
- 'mode' => $mode,
- 'is_open' => 0,
- 'keep-lab' => 0,
+ 'dir' => $absdir,
+ 'state' => {},
+ 'state-table' => {},
+ 'mode' => $mode,
+ 'is_open' => 0,
+ 'keep-lab' => 0,
};
bless $self, $class;
$self->_init ($dir);
@@ -184,7 +187,7 @@ sub get_package {
my $table;
my $result;
- if (blessed $pkg && $pkg->isa 'Lintian::Processable') {
+ if (blessed $pkg && $pkg->isa ('Lintian::Processable')) {
my $proc = $pkg_name;
$pkg_name = $proc->pkg_name;
$pkg_type = $proc->pkg_type;
@@ -192,7 +195,7 @@ sub get_package {
$pkg_arch = $proc->pkg_arch;
} else {
$pkg_name = $pkg;
- croak "Package name and type must be defined" unless $pkg_name && $pkg_type;
+ croak ("Package name and type must be defined") unless $pkg_name && $pkg_type;
}
$lindex = $self->_get_lab_index($pkg_type);
@@ -219,10 +222,10 @@ sub get_package {
# Unlike $lab->_load_lab_index, this uses the cache'd version if it is
# available.
sub _get_lab_index {
- my ($self, $type) = @_;
- croak "Unknown package type $pkg_type" unless $SUPPORTED_TYPES{$pkg_type};
+ my ($self, $pkg_type) = @_;
+ croak ("Unknown package type $pkg_type") unless $SUPPORTED_TYPES{$pkg_type};
# Fetch (or load) the index of that type
- return $self->{'state'}->{$pkg_type} // $self->_load_lab_index($pkg_type);
+ return $self->{'state-table'}->{$pkg_type} // $self->_load_lab_index($pkg_type);
}
# Unconditionally (Re-)loads the index of packages in the lab of a
@@ -249,13 +252,14 @@ sub _load_lab_index {
$pkg_name = $pd->{'package'};
}
if ($pkg_type eq 'source') {
- $lindex{$pkg_name}->{$pkg_version} = $pd;
+ $lindex->{$pkg_name}->{$pkg_version} = $pd;
} else {
$pkg_arch = $pd->{'architecture'};
- $lindex->{$pkg_name}->{$pkg_version}->{$pkg_ach} = $pd;
+ $lindex->{$pkg_name}->{$pkg_version}->{$pkg_arch} = $pd;
}
}
- $self->{'state'}->{$pkg_type} = $lindex;
+ $self->{'state'}->{$pkg_type} = $pf;
+ $self->{'state-table'}->{$pkg_type} = $lindex;
return $lindex;
}
@@ -305,23 +309,23 @@ sub create_lab {
my $topts = { CLEAN => !$keep, TMPDIR => 1 };
my $t = tempdir ('temp-lintian-lab-XXXXXX', $topts);
$dir = Cwd::abs_path ($t);
- croak "Could not resolve $dir: $!" unless $dir;
+ croak ("Could not resolve $dir: $!") unless $dir;
$self->{'dir'} = $dir;
$self->{'keep-lab'} = $keep;
} else {
# This should not be possible - but then again,
# code should not have any bugs either...
- croak 'Lab path may not be empty for a static lab';
+ croak ('Lab path may not be empty for a static lab');
}
}
# Create the top dir if needed - note due to Lintian::Lab->new
# and the above tempdir creation code, we know that $dir is
# absolute.
- croak "Cannot create $dir: $!" unless -d $dir or mkdir $dir;
+ croak ("Cannot create $dir: $!") unless -d $dir or mkdir $dir;
# Top dir exists, time to create the minimal directories.
unless (-d "$dir/info") {
- mkdir "$dir/info" or croak "mkdir $dir/info: $!";
+ mkdir "$dir/info" or croak ("mkdir $dir/info: $!");
$mid = 1; # remember we created the info dir
}
@@ -335,7 +339,7 @@ sub create_lab {
# ignore the error (if any) - we can only do so much
rmdir "$dir/info" if $mid;
$! = $err;
- croak "mkdir $dir/pool: $!";
+ croak ("mkdir $dir/pool: $!");
}
}
# Okay - $dir/info and $dir/pool exists... The subdirs in
@@ -367,15 +371,15 @@ $lab->create_lab.
sub open_lab {
my ($self) = @_;
- croak 'Lab is already open' if $self->is_open();
+ croak ('Lab is already open') if $self->is_open();
if ($self->{'mode'} eq LAB_MODE_TEMP) {
$self->create_lab() unless $self->lab_exists();
} else {
my $dir = $self->dir;
unless ($self->lab_exists()) {
my $msg = "Open Lab failed: ";
- croak "$msg: $dir does not exists" unless -e $dir;
- croak "$msg: $dir is not a lab or the lab is corrupt";
+ croak ("$msg: $dir does not exists") unless -e $dir;
+ croak ("$msg: $dir is not a lab or the lab is corrupt");
}
}
@@ -449,7 +453,7 @@ sub remove_lab {
$empty = 1;
} else {
# non-empty directory that does not look like a lintian lab!
- croak "$dir: Does not look like a lab";
+ croak ("$dir: Does not look like a lab");
}
}
@@ -464,13 +468,13 @@ sub remove_lab {
push @subdirs, 'changes' if -d "$dir/changes";
}
unless (delete_dir( map { "$dir/$_" } @subdirs )) {
- croak "delete_dir (\$contents): $!";
+ croak ("delete_dir (\$contents): $!");
}
}
# dynamic lab?
if ($self->{'mode'} eq LAB_MODE_TEMP) {
- rmdir $dir or croak "rmdir $dir: $!";
+ rmdir $dir or croak ("rmdir $dir: $!");
$self->{'dir'} = '';
}
@@ -487,6 +491,30 @@ sub _init {
my ($self) = @_;
}
+sub _entry_removed {
+ my ($self, $entry) = @_;
+ my $pkg_name = $entry->pkg_name;
+ my $pkg_type = $entry->pkg_type;
+
+ my $pf = $self->{'state'};
+ $pf->delete ($pkg_name);
+}
+
+sub _entry_created {
+ my ($self, $entry) = @_;
+ my $pkg_name = $entry->pkg_name;
+ my $pkg_type = $entry->pkg_type;
+
+ croak ("Not implemented");
+
+# my %data = (
+# 'source' => undef,
+# );
+# my $pf = $self->{'state'};
+# $pf->set ($pkg_name, \%data);
+
+}
+
=back
=head1 AUTHOR
@@ -497,3 +525,5 @@ Based on the work of various others.
=cut
+1;
+
diff --git a/lib/Lintian/Lab/Entry.pm b/lib/Lintian/Lab/Entry.pm
new file mode 100644
index 0000000..dad3fa8
--- /dev/null
+++ b/lib/Lintian/Lab/Entry.pm
@@ -0,0 +1,237 @@
+# Lintian::Lab::Entry -- Perl laboratory entry for lintian
+
+# 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.
+
+
+package Lab::Package;
+
+=head1 NAME
+
+Lintian::Lab::Entry - A package inside the Lab
+
+=head1 SYNOPSIS
+
+ use Lab;
+
+ my $lab = Lintian::Lab->new ("dir", "dist");
+ my $lpkg = $lab->get_lab_package ("name", "version", "arch", "type", "path");
+
+ # create the entry if it does not exist
+ $lpkg->create_entry unless $lpkg->entry_exists;
+
+ # Remove package from lab.
+ $lpkg->delete_lab_entry;
+
+=head1 DESCRIPTION
+
+=cut
+
+use base qw(Class::Accessor);
+
+use strict;
+use warnings;
+
+use Carp qw(croak);
+use File::Spec;
+
+use Lintian::Lab qw(:constants); # LAB_FORMAT
+
+use Util qw(delete_dir);
+
+=over 4
+
+=cut
+
+sub new {
+ my ($type, $lab, $pkg_name, $pkg_version, $pkg_type, $pkg_path, $base_dir) = @_;
+ my $self = {};
+ bless $self, $type;
+ croak("$pkg_path does not exist.") unless( -e $pkg_path );
+ $self->{pkg_name} = $pkg_name;
+ $self->{pkg_version} = $pkg_version;
+ $self->{pkg_path} = $pkg_path;
+ $self->{pkg_type} = $pkg_type;
+ $self->{lab} = $lab;
+ $self->{info} = undef; # load on demand.
+ # ask the lab to find the base directory of this package.
+ $self->{base_dir} = $base_dir;
+ # Figure out our unpack level and such
+ $self->_check();
+ return $self;
+}
+
+=item $lpkg->pkg_name()
+
+Returns the package name.
+
+=item $lpkg->pkg_version();
+
+Returns the version of the package.
+
+=item $lpkg->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 $lpkg->pkg_type()
+
+Returns the type of package (e.g. binary, source, udeb ...)
+
+=item $lpkg->base_dir()
+
+Returns the base directory of this package inside the lab.
+
+=cut
+
+Lab::Package->mk_ro_accessors(qw(pkg_name pkg_version pkg_path pkg_type base_dir));
+
+=item $lpkg->info()
+
+Returns the L<Lintian::Collect|info> object associated with this entry.
+
+=cut
+
+sub info {
+ my ($self) = @_;
+ my $info;
+ croak 'Cannot load info, extry does not exists' unless $self->entry_exists;
+ $info = $self->{info};
+ if ( ! defined $info ) {
+ $info = Lintian::Collect->new($self->pkg_name, $self->pkg_type, $self->base_dir);
+ $self->{info} = $info;
+ }
+ return $info;
+}
+
+
+=item $lpkg->clear_cache
+
+Clears any caches held; this includes discarding the L<Lintian::Collect|info> object.
+
+=cut
+
+sub clear_cache {
+ my ($self) = @_;
+ delete $self->{info};
+}
+
+=item $lpkg->delete_lab_entry()
+
+Removes all unpacked parts of the package in the lab. Returns a truth
+value if successful.
+
+=cut
+
+sub delete_lab_entry {
+ my ($self) = @_;
+ my $basedir = $self->{base_dir};
+ return 1 if( ! -e $basedir);
+ $self->clear_cache;
+ unless(delete_dir($basedir)) {
+ return 0;
+ }
+ $self->{lab}->_entry_removed ($self);
+ return 1;
+}
+
+=item $lpkg->entry_exists()
+
+Returns a truth value if the lab-entry exists.
+
+=cut
+
+sub entry_exists {
+ my ($self) = @_;
+ my $pkg_type = $self->{pkg_type};
+ my $base_dir = $self->{base_dir};
+
+ # Check if the relevant symlink exists.
+ if ($pkg_type eq 'changes'){
+ return 1 if -l "$base_dir/changes";
+ } elsif ($pkg_type eq 'binary' or $pkg_type eq 'udeb') {
+ return 1 if -l "$base_dir/deb";
+ } elsif ($pkg_type eq 'source'){
+ return 1 if -l "$base_dir/dsc";
+ }
+
+ # No unpack level and no symlink => the entry does not
+ # exist or it is too broken in its current state.
+ return 0;
+}
+
+=item $lpkg->create_entry()
+
+Creates a minimum lab-entry, in which collections and checks
+can be run. Note if it already exists, then this will do
+nothing.
+
+=cut
+
+sub create_entry {
+ my ($self) = @_;
+ my $pkg_type = $self->{pkg_type};
+ my $base_dir = $self->{base_dir};
+ my $pkg_path = $self->{pkg_path};
+ my $lab = $self->{lab};
+ my $link;
+ my $madedir = 0;
+ # It already exists.
+ return 1 if ($self->entry_exists());
+
+ unless (-d $base_dir) {
+ # if we are in a multi-arch or/and multi-version lab we may
+ # need to make more than one dir. On error we will only kill
+ # the "top dir" and that is enough.
+ system ('mkdir', '-p', $base_dir) == 0
+ or return 0;
+ $madedir = 1;
+ }
+ if ($pkg_type eq 'changes'){
+ $link = "$base_dir/changes";
+ } elsif ($pkg_type eq 'binary' or $pkg_type eq 'udeb') {
+ $link = "$base_dir/deb";
+ } elsif ($pkg_type eq 'source'){
+ $link = "$base_dir/dsc";
+ } else {
+ croak "create_entry cannot handle $pkg_type";
+ }
+ unless (symlink($pkg_path, $link)){
+ # "undo" the mkdir if the symlink fails.
+ rmdir($base_dir) if($madedir);
+ return 0;
+ }
+ if ($pkg_type eq 'source'){
+ # If it is a source package, pull in all the related files
+ # - else unpacked will fail or we would need a separate
+ # collection for the symlinking.
+ my $data = get_dsc_info($pkg_path);
+ my (undef, $dir, undef) = File::Spec->splitpath($pkg_path);
+ for my $fs (split(m/\n/o,$data->{'files'})) {
+ $fs =~ s/^\s*//o;
+ next if $fs eq '';
+ my @t = split(/\s+/o,$fs);
+ next if ($t[2] =~ m,/,o);
+ symlink("$dir/$t[2]", "$base_dir/$t[2]")
+ or croak("cannot symlink file $t[2]: $!");
+ }
+ }
+ $lab->_entry_created ($self);
+ return 1;
+}
+
--
Debian package checker
Reply to: