[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 cde8019ad5a9955104e6d5f67060e7661b6b27b6
Author: Niels Thykier <niels@thykier.net>
Date: Sat Sep 24 19:50:13 2011 +0200
Updated the Lab and the Lab::Entry
The Lintian::Lab::Entry uses a hash (stored in the status file)
to track collections that have been completed.
The code is not complete yet, but it can be used by Lintian to
replace temporary labs.
Signed-off-by: Niels Thykier <niels@thykier.net>
diff --git a/lib/Lintian/Lab.pm b/lib/Lintian/Lab.pm
index 467ed29..1c4b77b 100644
--- a/lib/Lintian/Lab.pm
+++ b/lib/Lintian/Lab.pm
@@ -44,6 +44,7 @@ use constant {
LAB_MODE_TEMP => 'temporary',
};
+
# A private table of suported types.
my %SUPPORTED_TYPES = (
'binary' => 1,
@@ -52,6 +53,8 @@ my %SUPPORTED_TYPES = (
'udeb' => 1,
);
+
+
# Export now due to cicular depends between Lab and Lab::Package.
our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
@@ -67,6 +70,8 @@ BEGIN {
use Util qw(delete_dir); # Used by $lab->remove_lab
+use Lintian::Lab::Entry;
+
=head1 NAME
Lintian::Lab -- Interface to the Lintian Lab
@@ -90,6 +95,8 @@ Lintian::Lab -- Interface to the Lintian Lab
$lab->close;
+=head1 DESCRIPTION
+
=head2 Methods
=over 4
@@ -108,8 +115,8 @@ sub new {
my $absdir;
my $mode = LAB_MODE_TEMP;
if ($dir) {
- $absdir = Cwd::abs_path($dir);
- croak ("Cannot resolve $dir: $!") unless $absdir;
+ $absdir = Cwd::abs_path ($dir);
+ croak "Cannot resolve $dir: $!" unless $absdir;
$mode = LAB_MODE_STATIC;
} else {
$absdir = ''; #Ensure it is defined.
@@ -182,39 +189,29 @@ case all other arguments are ignored.
sub get_package {
my ($self, $pkg, $pkg_type, $pkg_version, $pkg_arch) = @_;
my $pkg_name;
- my $path;
- my $lindex;
- my $table;
- my $result;
+ my $dir;
+ my $pkg_path;
+
+ croak 'Lab is not open' unless $self->is_open;
if (blessed $pkg && $pkg->isa ('Lintian::Processable')) {
- my $proc = $pkg_name;
- $pkg_name = $proc->pkg_name;
- $pkg_type = $proc->pkg_type;
- $pkg_version = $proc->pkg_version;
- $pkg_arch = $proc->pkg_arch;
+ $pkg_name = $pkg->pkg_name;
+ $pkg_type = $pkg->pkg_type;
+ $pkg_version = $pkg->pkg_version;
+ $pkg_arch = $pkg->pkg_arch;
+ $pkg_path = $pkg->pkg_path;
} 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;
+ croak 'Not implemented';
}
- $lindex = $self->_get_lab_index($pkg_type);
- $table = $lindex->{$pkg_name};
- return unless $table; # No package with this name of this type?
+ # TODO: Cache and check for existing entries to avoid passing out
+ # the same entry twice.
- # TODO allow version to be blank to mean "any" ?
- return unless defined $pkg_version; # Allow version "0"
+ $dir = $self->_pool_path ($pkg_name, $pkg_type, $pkg_version, $pkg_arch);
- $result = $table->{$pkg_version};
- return unless $result; # No package with that version?
-
- # Source packages have no "architecture", so we are done here.
- return $result if $pkg_type eq 'source';
-
- # TODO allow version to be blank to mean "any" ?
- return unless $pkg_arch;
-
- return $result->{$pkg_arch};
+ return Lintian::Lab::Entry->new ($self, $pkg_name, $pkg_version, $pkg_type, $pkg_path, $dir);
}
# Returns the index of packages in the lab of a given type (of packages).
@@ -223,9 +220,9 @@ sub get_package {
# available.
sub _get_lab_index {
my ($self, $pkg_type) = @_;
- croak ("Unknown package type $pkg_type") unless $SUPPORTED_TYPES{$pkg_type};
+ croak "Unknown package type $pkg_type" unless $SUPPORTED_TYPES{$pkg_type};
# Fetch (or load) the index of that type
- return $self->{'state-table'}->{$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
@@ -274,7 +271,7 @@ sub _pool_path {
} else {
$p = substr $pkg_name, 0, 1;
}
- $path .= "/$p/$pkg_name/${pkg_name}_${pkg_version}";
+ $path .= "pool/$p/$pkg_name/${pkg_name}_${pkg_version}";
$path .= "_${pkg_arch}" unless $pkg_type eq 'source';
$path .= "_${pkg_type}";
return $path;
@@ -309,23 +306,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
}
@@ -339,7 +336,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
@@ -371,15 +368,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();
+ $self->create_lab unless $self->lab_exists;
} else {
my $dir = $self->dir;
- unless ($self->lab_exists()) {
+ 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";
}
}
@@ -400,10 +397,10 @@ was created with "keep-lab" (see $lab->create_lab).
sub close_lab {
my ($self) = @_;
- return unless $self->lab_exists();
+ return unless $self->lab_exists;
if ($self->{'mode'} eq LAB_MODE_TEMP && !$self->{'keep-lab'}) {
# Temporary lab (without "keep-lab" property)
- $self->remove_lab();
+ $self->remove_lab;
} else {
my $dir = $self->dir;
while ( my ($pkg_type, $plist) = (each %{ $self->{'state'} }) ) {
@@ -453,7 +450,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";
}
}
@@ -468,13 +465,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'} = '';
}
@@ -491,6 +488,7 @@ sub _init {
my ($self) = @_;
}
+# event - triggered by Lintian::Lab::Entry
sub _entry_removed {
my ($self, $entry) = @_;
my $pkg_name = $entry->pkg_name;
@@ -500,19 +498,13 @@ sub _entry_removed {
$pf->delete ($pkg_name);
}
+# event - triggered by Lintian::Lab::Entry
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);
-
+ # FIXME: update $self->{'state'} etc.
}
=back
diff --git a/lib/Lintian/Lab/Entry.pm b/lib/Lintian/Lab/Entry.pm
index dad3fa8..efa0f74 100644
--- a/lib/Lintian/Lab/Entry.pm
+++ b/lib/Lintian/Lab/Entry.pm
@@ -19,7 +19,7 @@
# MA 02110-1301, USA.
-package Lab::Package;
+package Lintian::Lab::Entry;
=head1 NAME
@@ -27,10 +27,10 @@ Lintian::Lab::Entry - A package inside the Lab
=head1 SYNOPSIS
- use Lab;
+ use Lintian::Lab;
my $lab = Lintian::Lab->new ("dir", "dist");
- my $lpkg = $lab->get_lab_package ("name", "version", "arch", "type", "path");
+ my $lpkg = $lab->get_package ("name", "version", "arch", "type", "path");
# create the entry if it does not exist
$lpkg->create_entry unless $lpkg->entry_exists;
@@ -40,6 +40,12 @@ Lintian::Lab::Entry - A package inside the Lab
=head1 DESCRIPTION
+... FIXME ?
+
+=head2 METHODS
+
+=over 4
+
=cut
use base qw(Class::Accessor);
@@ -50,13 +56,9 @@ use warnings;
use Carp qw(croak);
use File::Spec;
-use Lintian::Lab qw(:constants); # LAB_FORMAT
-
-use Util qw(delete_dir);
-
-=over 4
+use Lintian::Lab;
-=cut
+use Util qw(delete_dir read_dpkg_control get_dsc_info);
sub new {
my ($type, $lab, $pkg_name, $pkg_version, $pkg_type, $pkg_path, $base_dir) = @_;
@@ -69,10 +71,11 @@ sub new {
$self->{pkg_type} = $pkg_type;
$self->{lab} = $lab;
$self->{info} = undef; # load on demand.
+ $self->{coll} = {};
# 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();
+
+ $self->_init();
return $self;
}
@@ -99,7 +102,7 @@ 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));
+Lintian::Lab::Entry->mk_ro_accessors(qw(pkg_name pkg_version pkg_path pkg_type base_dir));
=item $lpkg->info()
@@ -235,3 +238,114 @@ sub create_entry {
return 1;
}
+=item $lpkg->coll_version ($coll)
+
+Returns the version of the collection named $coll, if that
+$coll has been marked as finished.
+
+Returns the empty string if $coll has not been marked as finished.
+
+Note: The version can be 0.
+
+=cut
+
+sub coll_version {
+ my ($self, $coll) = @_;
+ return $self->{coll}->{$coll}//'';
+}
+
+=item $lpkg->is_coll_finished ($coll, $version)
+
+Returns a truth value if the collection $coll has been completed as
+its version is at least $version. The versions are assumed to be
+integers (the comparision is done with ">=").
+
+This returns 0 if the collection $coll has not been marked as
+finished.
+
+=cut
+
+sub is_coll_finished {
+ my ($self, $coll, $version) = @_;
+ my $c = $self->coll_version ($coll);
+ return 0 if $c eq '';
+ return $c >= $version;
+}
+
+# $lpkg->_mark_coll_finished ($coll, $version)
+#
+# non-public method to mark a collection as complete
+sub _mark_coll_finished {
+ my ($self, $coll, $version) = @_;
+ $self->{coll}->{$coll} = $version;
+ return 1;
+}
+
+# $lpkg->_clear_coll_status ($coll)
+#
+# Removes the notion that $coll has been fixed.
+sub _clear_coll_status {
+ my ($self, $coll) = @_;
+ delete $self->{coll}->{$coll};
+ return 1;
+}
+
+=item $lpkg->update_status_file ()
+
+Flushes the cached changes of which collections have been completed.
+
+This should also be called for new entries to create the status file.
+
+=cut
+
+sub update_status_file {
+ my ($self) = @_;
+ my $file;
+ my @sc;
+
+ return 0 unless $self->entry_exists;
+
+ $file = $self->base_dir () . '/.lintian-status';
+ open my $sfd, '>', $file or return 0;
+ print $sfd 'Lab-Format: ' . Lintian::Lab::LAB_FORMAT . "\n";
+
+ @sc = sort keys %{ $self->{coll} };
+ print $sfd "Collections: \n";
+ print $sfd ' ' . join (",\n ", map { "$_=$self->{coll}->{$_}" } @sc);
+ print $sfd "\n\n";
+ close $sfd or return 0;
+ return 1;
+}
+
+sub _init {
+ my ($self) = @_;
+ my $base_dir = $self->base_dir;
+ my @data;
+ my $head;
+ my $coll;
+ return unless $self->entry_exists;
+ return unless -e "$base_dir/.lintian-status";
+ @data = read_dpkg_control ("$base_dir/.lintian-status");
+ $head = $data[0];
+
+ # Check that we know the format.
+ return unless (Lintian::Lab::LAB_FORMAT eq $head->{'lab-format'}//'');
+
+ $coll = $head->{'collections'}//'';
+ $coll =~ s/\n/ /go;
+ foreach my $c (split m/\s*,\s*+/o, $coll) {
+ my ($cname, $cver) = split m/\s*=\s*/, $c;
+ $self->{coll}->{$cname} = $cver;
+ }
+}
+
+=back
+
+=head1 AUTHOR
+
+Niels Thykier <niels@thykier.net>
+
+=cut
+
+1;
+
--
Debian package checker
Reply to: