[SCM] Debian package checker branch, lab-refactor, updated. 2.5.3-65-g8f2cedf
The following commit has been merged in the lab-refactor branch:
commit 8f2cedf913d7d373b4312d0d3fff810598e640d9
Merge: 500a593470a46cb85e65d6bc7b9802861567f40e 69606e982789a7e80aa167046c697fa35422e38f
Author: Niels Thykier <niels@thykier.net>
Date: Sun Sep 25 09:05:24 2011 +0200
Merge branch 'master' into lab-refactor
diff --combined lib/Lab.pm
index e260389,6b0a382..5efad76
--- a/lib/Lab.pm
+++ b/lib/Lab.pm
@@@ -24,11 -24,9 +24,11 @@@ use strict
use warnings;
use base qw(Exporter);
+use Carp qw(croak);
+
# 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;
+use constant LAB_FORMAT => 10.1;
# Export now due to cicular depends between Lab and Lab::Package.
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
@@@ -47,7 -45,6 +47,7 @@@ use Util
# Only used by _populate_with_dist; remove when not needed
use Lintian::Output qw(:messages);
use Lintian::Command qw(spawn);
+use Lintian::Internal::PackageList;
use Lab::Package;
use Cwd;
@@@ -64,9 -61,7 +64,9 @@@ my $LINTIAN_ROOT = $main::LINTIAN_ROOT
sub new {
my ( $class, $dir ) = @_;
- my $self = {};
+ my $self = {
+ state => {},
+ };
bless $self, $class;
$self->_init( $dir );
@@@ -76,15 -71,12 +76,15 @@@
# returns a truth value if the lab is initialized and exists
sub is_lab {
my ( $self ) = @_;
-
- return unless $self->{dir};
- return -d "$self->{dir}/binary"
- && -d "$self->{dir}/udeb"
- && -d "$self->{dir}/source"
- && -d "$self->{dir}/info";
+ my $dir = $self->{dir};
+ return unless $dir;
+ # New style lab?
+ return 1 if -d "$dir/info" && -d "$dir/pool";
+ # 10-style lab?
+ return -d "$dir/binary"
+ && -d "$dir/udeb"
+ && -d "$dir/source"
+ && -d "$dir/info";
}
sub _init {
@@@ -100,7 -92,7 +100,7 @@@
# This code is here fore BACKWARDS COMPATABILITY!
# - we can kill it when LAB_FORMAT goes from 10 to 11.
# Basically this auto-upgrades existing static labs to support changes files
- if (-d "$absdir" && ! -d "$absdir/changes") {
+ if (-d "$absdir" && -d "$absdir/binary" && ! -d "$absdir/changes") {
mkdir("$absdir/changes", 0777)
or fail("cannot create lab directory $absdir/changes");
}
@@@ -114,8 -106,7 +114,7 @@@
$absdir = Cwd::realpath($dir);
fail("Cannot determine the absolute path of $dir: $!")
unless $absdir;
-
- if ($self->_do_setup( $dir )) {
+ if ($self->_do_setup( $absdir )) {
$created = 1;
last;
}
@@@ -155,7 -146,7 +154,7 @@@ sub _do_setup
}
# create base directories
- for my $subdir (qw( binary source udeb changes info )) {
+ for my $subdir (qw( pool info )) {
my $fulldir = "$dir/$subdir";
if (not -d $fulldir) {
mkdir($fulldir, 0777)
@@@ -204,121 -195,6 +203,121 @@@ sub _populate_with_dist
return 1;
}
+# $lab->get_entry($pkg_type, $pkg_name)
+#
+# Fetches an entry from the Lab
+#
+# On success this returns a Lab::Package, on error it returns C<undef>
+sub get_entry {
+ my ($self, $pkg_type, $pkg_name) = @_;
+ my $state = $self->_get_state($pkg_type);
+ my $lpkg;
+ my $pdata = $state->get($pkg_name);
+ my $lpdir;
+ return unless $pdata;
+
+ $lpdir = $self->_get_lpkg_dir($pkg_type, $pkg_name, $pdata->{'version'});
+ $lpkg = Lab::Package->new($self, $pkg_name, $pdata->{'version'},
+ $pkg_type, $pdata->{'file'}, $lpdir);
+ unless ($lpkg->entry_exists) {
+ # State is outdated (or $lpkg auto-removed itself)
+ $self->_lpkg_removed($pkg_type, $pkg_name);
+ return;
+ }
+ return $lpkg;
+}
+
+# Internal sub to find the directory in the Lab for a Lab entry
+sub _get_lpkg_dir {
+ my ($self, $pkg_type, $pkg_name, $pkg_version, $pkg_arch) = @_;
+ my $dir = "$self->{dir}/pool/";
+ if ($pkg_name =~ m/^lib/o) {
+ $dir .= substr $pkg_name, 0, 4;
+ } else {
+ $dir .= substr $pkg_name, 0, 1;
+ }
+ $dir .= "/$pkg_name";
+ $dir .= "${pkg_name}_${pkg_version}";
+ # avoid "_source_source" entries for source packages
+ $dir .= "_$pkg_arch" if $pkg_type ne 'source';
+ $dir .= "_$pkg_type";
+ return $dir;
+}
+
+# $lab->_load_state($pkg_type)
+#
+# Internal sub to load the state for a package type
+sub _get_state{
+ my ($self, $pkg_type) = @_;
+ my $state = $self->{state}->{$pkg_type};
+ return $state if defined $state;
+
+ my $file = $self->{dir} . "/info/${pkg_type}-packages";
+ $state = Lintian::Internal::PackageList->new($pkg_type);
+ $state->read_list($file);
+ $self->{state}->{$pkg_type} = $state;
+ return $state;
+}
+
+# $lab->_lpkg_removed($pkg_type, $pkg_name)
+#
+# Internal sub to notify the lab that a package was removed from the lab
+# Updates the state cache
+sub _lpkg_removed {
+ my ($self, $pkg_type, $pkg_name) = @_;
+ my $state = $self->_get_state($pkg_type);
+ $state->delete($pkg_name);
+ return 1;
+}
+
+# lab->generate_diffs(@lists)
+#
+# Each member of @lists must be a Lintian::Internal::PackageList.
+#
+# The lab will generate a diff between the given member and its
+# state for the given package type. The diffs are returned in the
+# same order as they appear in @lists.
+#
+# The diffs are valid until the original list is modified or a
+# package is added or removed to the lab.
+sub generate_diffs {
+ my ($self, @lists) = @_;
+ my $labdir = $self->{dir};
+ my $infodir;
+ my @diffs;
+ fail("$labdir is not a valid lab (run lintian --setup-lab first?).\n") unless $self->is_lab;
+ $infodir = "$labdir/info";
+ foreach my $list (@lists) {
+ my $type = $list->type;
+ my $lab_list = $self->_get_state($type);
+ push @diffs, $lab_list->diff($list);
+ }
+ return @diffs;
+}
+
+# $lab->write_state()
+#
+# Flushes the state data to the disk; this is important for static
+# labs to ensure that the package lists are in sync with the contents.
+#
+# Will croak if it fails.
+#
+# Note: this is a "no-op" for temp labs, since they are not intended to
+# be reused later.
+sub write_state {
+ my ($self) = @_;
+ my $infodir;
+ return 1 if $self->{mode} eq 'temporary';
+ croak "Lab does not exists" unless $self->is_lab;
+ $infodir = $self->{dir} . "/info";
+ foreach my $pkg_type (keys %{$self->{'state'}}){
+ my $state = $self->{$pkg_type};
+ next unless $state->dirty;
+ $state->write_list("$infodir/${pkg_type}-packages");
+ }
+ return 1;
+}
+
# Deletes the lab if (and only if) it exists and is a static lab
# Returns a truth value on success
sub delete_static {
@@@ -345,61 -221,49 +344,61 @@@ sub delete
# The backing sub for delete and delete_static
sub _do_delete {
my ( $self ) = @_;
+ my $dir = $self->{dir};
- return 0 unless $self->{dir};
+ return 0 unless $dir;
- v_msg("Removing $self->{dir} ...");
+ v_msg("Removing $dir ...");
# chdir to root (otherwise, the shell will complain if we happen
# to sit in the directory we want to delete :)
chdir('/');
# does the lab exist?
- unless (-d $self->{dir}) {
+ unless (-d $dir) {
# no.
- warning("cannot remove lab in directory $self->{dir} ! (directory does not exist)");
+ warning("cannot remove lab in directory $dir ! (directory does not exist)");
return 0;
}
# sanity check if $self->{dir} really points to a lab :)
- unless (-d "$self->{dir}/binary") {
- # binary/ subdirectory does not exist--empty directory?
- my @t = glob("$self->{dir}/*");
+ unless (-d "$dir/info") {
+ # info/ subdirectory does not exist--empty directory?
+ my @t = glob("$dir/*");
if ($#t+1 <= 2) {
# yes, empty directory--skip it
return 1;
} else {
# non-empty directory that does not look like a lintian lab!
- warning("directory $self->{dir} does not look like a lab! (please remove it yourself)");
+ warning("directory $dir does not look like a lab! (please remove it yourself)");
return 0;
}
}
# looks ok.
- unless (delete_dir("$self->{dir}/binary",
- "$self->{dir}/source",
- "$self->{dir}/udeb",
- "$self->{dir}/changes",
- "$self->{dir}/info")) {
- warning("cannot remove lab directory $self->{dir} (please remove it yourself)");
+ if ( -d "$dir/pool") {
+ # New lab style
+ unless (delete_dir("$dir/pool", "$dir/info")) {
+ warning("cannot remove lab directory $dir (please remove it yourself)");
+ return 0;
+ }
+ } else {
+ # 10-style Lab
+ unless (delete_dir("$dir/binary",
+ "$dir/source",
+ "$dir/udeb",
+ "$dir/changes",
+ "$dir/info")) {
+ warning("cannot remove lab directory $dir (please remove it yourself)");
+ return 0;
+ }
}
# dynamic lab?
if ($self->{mode} eq 'temporary') {
- if (rmdir($self->{dir}) != 1) {
- warning("cannot remove lab directory $self->{dir} (please remove it yourself)");
+ if (rmdir($dir) != 1) {
+ warning("cannot remove lab directory $dir (please remove it yourself)");
+ return 0;
}
}
@@@ -423,7 -287,6 +422,7 @@@
'udeb' => 'udeb',
);
+ # deprecated - needs a reasonable public API replacement
sub get_lab_package {
my ($self, $pkg_name, $pkg_version, $pkg_arch, $pkg_type, $pkg_path) = @_;
my $vpkg_type = $pkg_types{$pkg_type};
@@@ -431,7 -294,9 +430,7 @@@
my $dir;
fail("Unknown package type $pkg_type") unless($vpkg_type);
fail("Could not resolve the path of $pkg_path") unless($realpath);
- $dir = $self->{dir} . '/' . $vpkg_type . '/' . $pkg_name;
- $dir .= '/' . $pkg_version if $self->_supports_multiple_versions();
- $dir .= '/' . $pkg_arch if $self->_supports_multiple_architectures();
+ $dir = $self->_get_lpkg_dir($vpkg_type, $pkg_name, $pkg_version, $pkg_arch);
return Lab::Package->new ($self, $pkg_name, $pkg_version, $vpkg_type,
$realpath, $dir);
--
Debian package checker
Reply to: