[SCM] Debian package checker branch, master, updated. 2.5.0-rc2-122-g12888e8
The following commit has been merged in the master branch:
commit ec1074d88902088c54b43adabfb17ed90347d6ce
Author: Niels Thykier <niels@thykier.net>
Date: Wed Jan 5 16:45:37 2011 +0100
Added (incomplete) Lab::Package to represent a package inside the Lab.
diff --git a/lib/Lab/Package.pm b/lib/Lab/Package.pm
new file mode 100644
index 0000000..ecbeaff
--- /dev/null
+++ b/lib/Lab/Package.pm
@@ -0,0 +1,290 @@
+# Lab::Package -- Perl laboratory package 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
+
+Lab::Package - A package inside the Lab
+
+=head1 SYNOPSIS
+
+ use Lab;
+
+ my $lab = new Lab("dir", "dist");
+ my $lpkg = $lab->get_lab_package("name", "type", "path");
+
+ # reduce unpack level of the package.
+ $lpkg->reduce_unpack(1);
+ # Remove package from lab.
+ $lpkg->delete_lab_entry();
+
+=head1 DESCRIPTION
+
+Hallo world
+
+=cut
+
+use base qw(Class::Accessor);
+
+use strict;
+
+use Util;
+use Lintian::Output qw(:messages); # debug_msg and warning
+
+# We use require since Lab also depends on us.
+use Lab qw(:constants); # LAB_FORMAT
+
+=head1 METHODS
+
+=over 4
+
+=item new Lab::Package($lab, $pkg_type, $pkg_name, $pkg_path, $base_dir)
+
+Creates a new Lab::Package inside B<$lab>. B<$pkg_type> denotes the
+(long) type of package (e.g. binary, source, udeb ...) and
+B<$pkg_name> is the name of the package. B<$pkg_path> should be the
+absolute path to the packed version of the package (needed during
+unpackaging etc.). B<$base_dir> is the base directory of the package
+inside the Lab.
+
+Note: this method should only be used by the Lab.
+
+=cut
+
+sub new{
+ my ($class, $lab, $pkg_name, $pkg_version, $pkg_type, $pkg_path, $base_dir) = @_;
+ my $self = {};
+ bless $self, $class;
+ fail("$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;
+ # 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;
+}
+
+
+=pod
+
+=item $lpkg->lab()
+
+Returns the lab this package is associated with.
+
+=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.
+
+=item $lpkg->unpack_level()
+
+Returns the current unpack level.
+
+=cut
+
+Lab::Package->mk_accessors(qw(lab pkg_name pkg_version pkg_path pkg_type base_dir unpack_level));
+
+=pod
+
+=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};
+ debug_msg(1, "Removing package in lab ...");
+ unless(delete_dir($basedir)) {
+ warning("cannot remove directory $basedir: $!");
+ return 0;
+ }
+ return 1;
+}
+
+=pod
+
+=item $lpkg->reduce_unpack($new_level)
+
+Reduce the unpack level to B<$new_level>. Returns the unpack level
+after the operation has finished. If B<$new_level> is less than 1,
+then this will call delete_lab_entry. Returns -1 in case of an
+error.
+
+Note if the current level is lower than the new requested level, then
+nothing happens and the currnet level is returned instead.
+
+=cut
+
+sub reduce_unpack {
+ my ($self, $new_level) = @_;
+ my $level = $self->{unpack_level};
+ return $level if($level <= $new_level);
+ if($new_level < 1){
+ return -1 unless($self->delete_lab_entry());
+ return 0;
+ }
+
+ if($new_level < 2){
+ my $base = $self->{base_dir};
+ $self->{unpack_level} = $new_level;
+ $self->remove_status_file();
+ # remove unpacked/ directory
+ debug_msg(1, "Decreasing unpack level to 1 (removing files) ...");
+ if ( -l "$base/unpacked" ) {
+ delete_dir("$base/".readlink("$base/unpacked"))
+ or return -1;
+ delete_dir("$base/unpacked") or return -1;
+ } else {
+ delete_dir("$base/unpacked") or return -1;
+ }
+ return $new_level;
+ }
+
+ # This should not happen unless we implement a new unpack level.
+ fail("Unhandled reduce_unpack case to $new_level from $level");
+}
+
+## FIXME - does this really need to be public?
+sub remove_status_file{
+ my ($self) = @_;
+ my $stfile = "$self->{base_dir}/.lintian-status";
+ return 1 unless( -e $stfile );
+ if(!unlink($stfile)){
+ warning("cannot remove status file $stfile: $!");
+ return 0;
+ }
+ return 1;
+}
+
+#End of public methods
+
+=pod
+
+=back
+
+=cut
+
+## INTERNAL METHODS ##
+
+# Determines / Guesses the current unpack level - used by the constructor.
+sub _check {
+ my ($self) = @_;
+ my $act_unpack_level = 0;
+ my $basedir = $self->{base_dir};
+ if( -d $basedir ) {
+ my $remove_basedir = 0;
+ my $pkg_path = $self->{pkg_path};
+ my $data;
+ my $pkg_version = $self->{pkg_version};
+
+ # there's a base dir, so we assume that at least
+ # one level of unpacking has been done
+ $act_unpack_level = 1;
+
+ # lintian status file exists?
+ unless (-f "$basedir/.lintian-status") {
+ v_msg("No lintian status file found (removing old directory in lab)");
+ $remove_basedir = 1;
+ goto REMOVE_BASEDIR;
+ }
+
+ # read unpack status -- catch any possible errors
+ eval { ($data) = read_dpkg_control("$basedir/.lintian-status"); };
+ if ($@) { # error!
+ v_msg($@);
+ $remove_basedir = 1;
+ goto REMOVE_BASEDIR;
+ }
+
+ # compatible lintian version?
+ if (not exists $data->{'lab-format'} or ($data->{'lab-format'} < LAB_FORMAT)) {
+ v_msg("Lab directory was created by incompatible lintian version");
+ $remove_basedir = 1;
+ goto REMOVE_BASEDIR;
+ }
+
+ # version up to date?
+ if (not exists $data->{'version'} or ($data->{'version'} ne $pkg_version)) {
+ debug_msg(1, "Removing package in lab (newer version exists) ...");
+ $remove_basedir = 1;
+ goto REMOVE_BASEDIR;
+ }
+
+ # file modified?
+ my $timestamp;
+ my @stat;
+ unless (@stat = stat $pkg_path) {
+ warning("cannot stat file $pkg_path: $!");
+ } else {
+ $timestamp = $stat[9];
+ }
+ if ((not defined $timestamp) or (not exists $data->{'timestamp'}) or ($data->{'timestamp'} != $timestamp)) {
+ debug_msg(1, "Removing package in lab (package has been changed) ...");
+ $remove_basedir = 1;
+ goto REMOVE_BASEDIR;
+ }
+
+ REMOVE_BASEDIR:
+ if ($remove_basedir) {
+ my $pkg_name = $self->{pkg_name};
+ my $lab = $self->{lab};
+ v_msg("Removing $pkg_name");
+ $self->delete_lab_entry() or die("Could not remove $pkg_name from lab.");
+ $act_unpack_level = 0;
+ }
+ }
+ $self->{unpack_level} = $act_unpack_level;
+ return 1;
+}
+
+1;
+
+
+=head1 AUTHOR
+
+Niels Thykier <niels@thykier.net>
+
+=cut
+
--
Debian package checker
Reply to: