[Debpool-commits] [SCM] Debpool Project Repository branch, master, updated. debian/0.4.0-4-g0b4bb18
Andres Mejia
mcitadel at gmail.com
Sun Oct 26 02:36:36 UTC 2008
The following commit has been merged in the master branch:
commit 0b4bb18e940cc1b7ea553810c00eb419ca2e5821
Author: Andres Mejia <mcitadel at gmail.com>
Date: Sat Oct 25 22:36:29 2008 -0400
Start implementing new module (Dpkg.pm)
diff --git a/MANIFEST b/MANIFEST
index 2236d95..a0cf80f 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -8,6 +8,7 @@ lib/DebPool/Bzip2.pm
lib/DebPool/Config.pm
lib/DebPool/DB.pm
lib/DebPool/Dirs.pm
+lib/DebPool/Dpkg.pm
lib/DebPool/GnuPG.pm
lib/DebPool/Gzip.pm
lib/DebPool/Logging.pm
diff --git a/debian/changelog b/debian/changelog
index 27f3198..cbe1df0 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,11 @@
+debpool (0.4.2) experimental; urgency=low
+
+ * Create a new module (Dpkg.pm) that will handle our dpkg routines in a pure
+ Perl process. (NOT YET IMPLEMENTED).
+ * Updated copyright file. Dpkg.pm is licensed under GPL.
+
+ -- Andres Mejia <mcitadel at gmail.com> Sat, 25 Oct 2008 22:23:11 -0400
+
debpool (0.4.1) experimental; urgency=low
* Added 'DM-Upload-Allowed: yes' field.
diff --git a/debian/copyright b/debian/copyright
index feb1103..d1c477f 100644
--- a/debian/copyright
+++ b/debian/copyright
@@ -28,3 +28,22 @@ License: BSD-3
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
+
+Files: lib/DebPool/Dpkg.pm
+Copyright: (C) 2008 Andres Mejia <mcitadel at gmail.com>
+License: GPL-3+
+ 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 3 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, see <http://www.gnu.org/licenses/>.
+ .
+ On Debian GNU/Linux systems, the complete text of the GNU General Public
+ License can be found in ‘/usr/share/common-licenses/GPL’.
diff --git a/lib/DebPool/Dpkg.pm b/lib/DebPool/Dpkg.pm
new file mode 100644
index 0000000..538af0b
--- /dev/null
+++ b/lib/DebPool/Dpkg.pm
@@ -0,0 +1,173 @@
+package DebPool::Dpkg;
+
+###
+#
+# DebPool::Dpkg - Module that performs dpkg operations using pure Perl
+#
+# Copyright 2008 Andres Mejia. All rights reserved.
+#
+# 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 3 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, see <http://www.gnu.org/licenses/>.
+#
+# $Id: Dpkg.pm 27 2008-10-25 03:06:59Z andres $
+#
+###
+
+# We use 'our', so we must have at least Perl 5.6
+
+require 5.006_000;
+
+# Always good ideas.
+
+use strict;
+use warnings;
+
+use File::Temp qw(tempfile); # For making tempfiles
+use Archive::Ar; # For extracting ar files (the format for .deb files)
+use Archive::Tar; # For extracting tar files
+
+use DebPool::Logging qw(:functions :facility :level);
+
+### Module setup
+
+BEGIN {
+ use Exporter ();
+ our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+ # Version checking
+ $VERSION = '0.1.5';
+
+ @ISA = qw(Exporter);
+
+ @EXPORT = qw(
+ );
+
+ @EXPORT_OK = qw(
+ &Dpkg_Field
+ &Compare_Version
+ );
+
+ %EXPORT_TAGS = (
+ 'functions' => [qw(&Dpkg_Field &Compare_Version)],
+ 'vars' => [qw()],
+ );
+}
+
+### Exported package globals
+
+# None
+
+### Non-exported package globals
+
+# Thread-safe? What's that? Package global error value. We don't export
+# this directly, because it would conflict with other modules.
+
+our($Error);
+
+### File lexicals
+
+# None
+
+### Constant functions
+
+# None
+
+### Meaningful functions
+
+# Dpkg_Field($file, $fields)
+# Parameter data types (string, array_ref)
+#
+# Method that mimics the behavior of 'dpkg --field <deb_file> [fields]'. This is
+# the pure perl method of performing said operation.
+# Note that this is actually a dpkg-deb operation.
+
+sub Dpkg_Field {
+ my ($file, $fields) = @_;
+
+ # First get the contents of the control gzip tarball from the deb file.
+ my $ar = Archive::Ar->new($file);
+ if (!$ar) {
+ my $msg = "Couldn't load deb file $file: $!";
+ Log_Message($msg, LOG_GENERAL, LOG_ERROR);
+ return;
+ }
+ my $ar_control = $ar->get_content("control.tar.gz");
+
+ # Now write the control gzip tarball into a tempfile.
+ my ($control_tar_gz_fh, $control_tar_gz) = tempfile();
+ print $control_tar_gz_fh $ar_control->{data};
+ binmode $control_tar_gz_fh;
+
+ # Now extract and read the contents of the control file to an array.
+ my ($control_fh, $control_file) = tempfile();
+ my $control_tar_object = Archive::Tar->new($control_tar_gz,1);
+ if (!$control_tar_object) {
+ my $msg = "Couldn't load control.tar.gz file from $file: $!";
+ Log_Message($msg, LOG_GENERAL, LOG_ERROR);
+ return;
+ }
+ $control_tar_object->extract_file('./control',$control_file);
+ my @control_file_data = <$control_fh>;
+
+ # Now place the contents of the control file into an array. If we passed any
+ # fields to grab, only include the data for those fields in the array.
+ my @output;
+ my $pattern;
+ $pattern = "(" . join('|', @{$fields}) . ")" if ($fields);
+ my $newfield = 0; # use as boolean
+ foreach my $tmp (@control_file_data) {
+ if (!$pattern) {
+ push @output, $tmp;
+ } elsif ($tmp =~ /^$pattern:/) {
+ $newfield = 1;
+ push @output, $tmp;
+ } elsif ($newfield and $tmp =~ /^ /) {
+ push @output, $tmp;
+ } else {
+ $newfield = 0;
+ }
+ }
+
+ # Finally, strip the field name from the output array we only specified one
+ # field to grab data from. Then return the output as an array reference.
+ $output[0] =~ s/^$pattern: (.*)/$2/ if ($fields and @{$fields} eq 1);
+ return \@output;
+}
+
+# Compare_Version($version1, $operator, $version2)
+# Paramater data types (string, string, string)
+#
+# Method that compares two version numbers and returns either 1 or 0 (true or
+# false) based on whether '$version1 $operator $version2' is a true statement.
+#
+# TODO: For now, we just use dpkg. We'll make this a pure Perl subroutine later.
+
+sub Compare_Version {
+ my ($version1, $operator, $version2) = @_;
+
+ my $dpkg_bin = '/usr/bin/dpkg';
+ my @args = ('--compare-versions', $version1, $operator, $version2);
+ if (system($dpkg_bin, @args) eq 0) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+END {}
+
+1;
+
+__END__
+
+# vim:set tabstop=4 expandtab:
diff --git a/lib/DebPool/Packages.pm b/lib/DebPool/Packages.pm
index 5616208..6763adc 100644
--- a/lib/DebPool/Packages.pm
+++ b/lib/DebPool/Packages.pm
@@ -478,9 +478,7 @@ sub Reject_Package {
# Verify_MD5($file, $md5)
#
# Verifies the MD5 checksum of $file against $md5. Returns 1 if it matches,
-# 0 if it doesn't, and undef (also setting $Error) if an error occurs. This
-# routine uses the dpkg md5sum utility, to avoid pulling in a dependancy on
-# Digest::MD5.
+# 0 if it doesn't, and undef (also setting $Error) if an error occurs.
sub Verify_MD5 {
use DebPool::Logging qw(:functions :facility :level);
diff --git a/pure-perl-testing/debperltest b/pure-perl-testing/debperltest
index 093f88f..e308c07 100755
--- a/pure-perl-testing/debperltest
+++ b/pure-perl-testing/debperltest
@@ -4,6 +4,9 @@ use strict;
use warnings;
use Getopt::Long;
+use File::Temp qw(tempfile tempdir); # For making tempfiles and tempdirs
+use Archive::Ar; # For extracting ar files (the format for .deb files)
+use Archive::Tar; # For extracting tar files
my ($previous, $next, $file);
GetOptions (
@@ -170,76 +173,53 @@ sub Compare_Char {
}
}
-# Method that mimics the behavior of 'dpkg --info <deb_file>'. This is the pure
-# perl method of performing said operation.
-sub Dpkg_Info {
- my ($file) = @_;
+# Dpkg_Field($file, $fields)
+# Parameter data types (string, array_ref)
+#
+# Method that mimics the behavior of 'dpkg --field <deb_file> [fields]'. This is
+# the pure perl method of performing said operation.
+# Note that this is actually a dpkg-deb operation.
+sub Dpkg_Field {
+ my ($file, $fields) = @_;
- use Archive::Ar; # For extracting ar files
- use File::Temp qw(tempfile tempdir);
-
- # First read the contents of the deb file.
+ # First get the contents of the control gzip tarball from the deb file.
my $ar = Archive::Ar->new($file);
- my $files = $ar->list_files(); #list_files() returns an array_ref
- my $ar_debian_binary = $ar->get_content("debian-binary");
+ # get_content() returns a hash reference
my $ar_control = $ar->get_content("control.tar.gz");
- my $ar_data = $ar->get_content("data.tar.gz");
- my $package_version = $ar_debian_binary->{data};
- chomp $package_version;
- # Now place the contents of the control file into a tempfile.
- my ($control_tar_fh, $control_tar_file) = tempfile();
- print $control_tar_fh $ar_control->{data};
- binmode $control_tar_fh;
+ # Now write the control gzip tarball into a tempfile.
+ my ($control_tar_gz_fh, $control_tar_gz) = tempfile();
+ print $control_tar_gz_fh $ar_control->{data};
+ binmode $control_tar_gz_fh;
- # Now extract the contents of that control file to a tempdir.
- my $tmpdir = tempdir( CLEANUP => 1 );
- system('tar', '-C', $tmpdir, '-xzf', $control_tar_file);
- open(my $fh, '<', "$tmpdir/control");
- my @control_file = <$fh>;
- close $fh;
+ # Now extract and read the contents of the control file to an array.
+ my ($control_fh, $control_file) = tempfile();
+ my $control_tar_object = Archive::Tar->new($control_tar_gz,1);
+ $control_tar_object->extract_file('./control',$control_file);
+ my @control_file_data = <$control_fh>;
- # Now check the contents of the extracted files
- my @files;
- opendir(my $dh, $tmpdir) or die "Couldn't open $tmpdir: $!";
- foreach my $tmp (grep(!/^\.{1,2}$/, readdir($dh))) {
- push @files, "$tmpdir/$tmp";
- }
- closedir $dh;
- @files = sort @files;
- my @contents;
- foreach my $tmp (@files) {
- my $size = (stat($tmp))[7];
- open(my $fh, '<', $tmp);
- my @filedata = <$fh>;
- close $fh;
- my $lines = @filedata;
- my $filename = $tmp;
- $filename =~ s/^.*\/(.*)$/$1/;
- my $exe_type = $filedata[0];
- $exe_type =~ s/^([^\s]+).*$/$1/;
- my $string = sprintf '%14s', "$size bytes,";
- $string .= sprintf '%12s', "$lines lines";
- if (-x $tmp) {
- $string .= " * " . sprintf('%-21s', $filename) . $exe_type;
+ # Now place the contents of the control file into an array. If we passed any
+ # fields to grab, only include the data for those fields in the array.
+ my @output;
+ my $pattern;
+ $pattern = "(" . join('|', @{$fields}) . ")" if ($fields);
+ my $newfield = 0; # use as boolean
+ foreach my $tmp (@control_file_data) {
+ if (!$pattern) {
+ push @output, $tmp;
+ } elsif ($tmp =~ /^$pattern:/) {
+ $newfield = 1;
+ push @output, $tmp;
+ } elsif ($newfield and $tmp =~ /^ /) {
+ push @output, $tmp;
} else {
- $string .= " $filename\n";
+ $newfield = 0;
}
- push @contents, $string;
}
- # Now place the contents of the data we collected into an array and then
- # return a reference to the array.
- my @output;
- push @output, " new debian package, version $package_version.\n";
- push @output, " size $ar_data->{size} bytes: control archive= " .
- "$ar_control->{size} bytes.\n";
- foreach my $tmp (@contents) {
- push @output, " $tmp";
- }
- foreach my $tmp (@control_file) {
- push @output, " $tmp";
- }
+ # Finally, strip the field name from the output array we only specified one
+ # field to grab data from. Then return the output as an array reference.
+ $output[0] =~ s/^$pattern: (.*)/$2/ if ($fields and @{$fields} eq 1);
return \@output;
}
@@ -265,7 +245,7 @@ if ($previous && $next) {
print "Previous $previous is greater than Next $next\n";
}
} elsif ($file) {
- my $output = Dpkg_Info($file);
+ my $output = Dpkg_Field($file, ['Description',]);
foreach my $tmp (@{$output}) {
print "$tmp";
}
--
Debpool Project Repository
More information about the Debpool-commits
mailing list