Dpkg::Compression: new API based on public functions

This API change requires lots of adjustements through the source code.

scripts/Dpkg/Compression.pm

@@ -1,3 +1,5 @@
+# Copyright © 2010 Raphaël Hertzog <hertzog@debian.org>
+#
 # 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
@@ -17,27 +19,126 @@ use strict;
 use warnings;
 
 use base qw(Exporter);
-our @EXPORT = qw(@comp_supported %comp_supported %comp_ext $comp_regex
-		 %comp_prog %comp_decomp_prog
-		 get_compression_from_filename);
-
-our @comp_supported = qw(gzip bzip2 lzma xz);
-our %comp_supported = map { $_ => 1 } @comp_supported;
-our %comp_ext = (gzip => 'gz', bzip2 => 'bz2', lzma => 'lzma', xz => 'xz');
-our $comp_regex = '(?:gz|bz2|lzma|xz)';
-our %comp_prog = (gzip => 'gzip', bzip2 => 'bzip2', lzma => 'lzma',
-		  xz => 'xz');
-our %comp_decomp_prog = (gzip => 'gunzip', bzip2 => 'bunzip2', lzma => 'unlzma',
-			 xz => 'unxz');
-
-sub get_compression_from_filename {
+our @EXPORT = qw($compression_re_file_ext compression_get_list
+		 compression_is_supported compression_get_property
+		 compression_guess_from_filename);
+
+=head1 NAME
+
+Dpkg::Compression - simple database of available compression methods
+
+=head1 DESCRIPTION
+
+This modules provides a few public funcions and a public regex to
+interact with the set of supported compression methods.
+
+=head1 EXPORTED VARIABLES
+
+=over 4
+
+=cut
+
+my $COMP = {
+    "gzip" => {
+	"file_ext" => "gz",
+	"comp_prog" => "gzip",
+	"decomp_prog" => "gunzip",
+    },
+    "bzip2" => {
+	"file_ext" => "bz2",
+	"comp_prog" => "bzip2",
+	"decomp_prog" => "bunzip2",
+    },
+    "lzma" => {
+	"file_ext" => "lzma",
+	"comp_prog" => "lzma",
+	"decomp_prog" => "unlzma",
+    },
+    "xz" => {
+	"file_ext" => "xz",
+	"comp_prog" => "xz",
+	"decomp_prog" => "unxz",
+    },
+};
+
+=item $compression_re_file_ext
+
+A regex that matches a file extension of a file compressed with one of the
+supported compression methods.
+
+=back
+
+=cut
+
+my $regex = join "|", map { $_->{"file_ext"} } values %$COMP;
+our $compression_re_file_ext = qr/(?:$regex)/;
+
+=head1 EXPORTED FUNCTIONS
+
+=over 4
+
+=item my @list = compression_get_list()
+
+Returns a list of supported compression methods (sorted alphabetically).
+
+=cut
+
+sub compression_get_list {
+    return sort keys %$COMP;
+}
+
+=item compression_is_supported($comp)
+
+Returns a boolean indicating whether the give compression method is
+known and supported.
+
+=cut
+
+sub compression_is_supported {
+    return exists $COMP->{$_[0]};
+}
+
+=item compression_get_property($comp, $property)
+
+Returns the requested property of the compression method. Returns undef if
+either the property or the compression method doesn't exist. Valid
+properties currently include "file_ext" for the file extension,
+"comp_prog" for the name of the compression program and "decomp_prog" for
+the name of the decompression program.
+
+=cut
+
+sub compression_get_property {
+    my ($comp, $property) = @_;
+    return undef unless compression_is_supported($comp);
+    return $COMP->{$comp}{$property} if exists $COMP->{$comp}{$property};
+    return undef;
+}
+
+=item compression_guess_from_filename($filename)
+
+Returns the compression method that is likely used on the indicated
+filename based on its file extension.
+
+=cut
+
+sub compression_guess_from_filename {
     my $filename = shift;
-    foreach my $comp (@comp_supported) {
-        if ($filename =~ /^(.*)\.\Q$comp_ext{$comp}\E$/) {
+    foreach my $comp (compression_get_list()) {
+	my $ext = compression_get_property($comp, "file_ext");
+        if ($filename =~ /^(.*)\.\Q$ext\E$/) {
 	    return $comp;
         }
     }
     return undef;
 }
 
+=back
+
+=head1 AUTHOR
+
+Raphaël Hertzog <hertzog@debian.org>.
+
+=cut
+
 1;

scripts/Dpkg/Compression/CompressedFile.pm

@@ -291,7 +291,7 @@ sub set_filename {
     if (defined($add_comp_ext)) {
 	*$self->{"add_comp_ext"} = $add_comp_ext;
     }
-    if (*$self->{"add_comp_ext"} and $filename =~ /\.$comp_regex$/) {
+    if (*$self->{"add_comp_ext"} and $filename =~ /\.$compression_re_file_ext$/) {
 	warning("filename %s already has an extension of a compressed file " .
 	        "and add_comp_ext is active", $filename);
     }
@@ -317,7 +317,8 @@ sub get_filename {
 	} elsif ($comp eq "none") {
 	    return *$self->{"filename"};
 	} else {
-	    return *$self->{"filename"} . "." . $comp_ext{$comp};
+	    return *$self->{"filename"} . "." .
+	           compression_get_property($comp, "file_ext");
 	}
     } else {
 	return *$self->{"filename"};
@@ -339,7 +340,7 @@ sub use_compression {
     if ($comp eq "none") {
 	return 0;
     } elsif ($comp eq "auto") {
-	$comp = get_compression_from_filename($self->get_filename());
+	$comp = compression_guess_from_filename($self->get_filename());
 	*$self->{"compressor"}->set_compression($comp) if $comp;
     }
     return $comp;

scripts/Dpkg/Compression/Compressor.pm

@@ -32,7 +32,7 @@ our $default_compression_level = 9;
 sub set_default_compression {
     my ($self, $method) = @_;
     error(_g("%s is not a supported compression"), $method)
-	    unless $comp_supported{$method};
+	    unless compression_is_supported($method);
     $default_compression = $method;
 }
 
@@ -58,7 +58,7 @@ sub new {
 sub set_compression {
     my ($self, $method) = @_;
     error(_g("%s is not a supported compression method"), $method)
-	    unless $comp_supported{$method};
+	    unless compression_is_supported($method);
     $self->{"compression"} = $method;
 }
 
@@ -71,7 +71,7 @@ sub set_compression_level {
 
 sub get_compress_cmdline {
     my ($self) = @_;
-    my @prog = ($comp_prog{$self->{"compression"}});
+    my @prog = (compression_get_property($self->{"compression"}, "comp_prog"));
     my $level = "-" . $self->{"compression_level"};
     $level = "--" . $self->{"compression_level"}
 	    if $self->{"compression_level"} =~ m/best|fast/;
@@ -81,7 +81,7 @@ sub get_compress_cmdline {
 
 sub get_uncompress_cmdline {
     my ($self) = @_;
-    return ($comp_decomp_prog{$self->{"compression"}});
+    return (compression_get_property($self->{"compression"}, "decomp_prog"));
 }
 
 sub _sanity_check {

scripts/Dpkg/Source/Package.pm

@@ -242,7 +242,7 @@ sub get_basename {
 
 sub find_original_tarballs {
     my ($self, $ext) = @_;
-    $ext ||= $comp_regex;
+    $ext ||= $compression_re_file_ext;
     my $basename = $self->get_basename();
     my @tar;
     foreach my $dir (".", $self->{'basedir'}, $self->{'options'}{'origtardir'}) {
@@ -332,7 +332,8 @@ sub extract {
         my $basename = $self->get_basename();
         my ($dirname, $destdir) = fileparse($newdirectory);
         $destdir ||= "./";
-        foreach my $orig (grep { /^\Q$basename\E\.orig(-\w+)?\.tar\.$comp_regex$/ }
+	my $ext = $compression_re_file_ext;
+        foreach my $orig (grep { /^\Q$basename\E\.orig(-\w+)?\.tar\.$ext$/ }
                           $self->get_files())
         {
             my $src = File::Spec->catfile($self->{'basedir'}, $orig);

scripts/Dpkg/Source/Package/V1.pm

@@ -292,7 +292,7 @@ sub do_build {
 	my ($ntfh, $newtar) = tempfile("$tarname.new.XXXXXX",
 				       DIR => getcwd(), UNLINK => 0);
 	my $tar = Dpkg::Source::Archive->new(filename => $newtar,
-		    compression => get_compression_from_filename($tarname),
+		    compression => compression_guess_from_filename($tarname),
 		    compression_level => $self->{'options'}{'comp_level'});
 	$tar->create(options => \@tar_ignore, 'chdir' => $tardirbase);
 	$tar->add_directory($tardirname);

scripts/Dpkg/Source/Package/V2.pm

@@ -89,16 +89,17 @@ sub do_extract {
     my $basenamerev = $self->get_basename(1);
 
     my ($tarfile, $debianfile, %origtar, %seen);
+    my $re_ext = $compression_re_file_ext;
     foreach my $file ($self->get_files()) {
-        (my $uncompressed = $file) =~ s/\.$comp_regex$//;
+        (my $uncompressed = $file) =~ s/\.$re_ext$//;
         error(_g("duplicate files in %s source package: %s.*"), "v2.0",
               $uncompressed) if $seen{$uncompressed};
         $seen{$uncompressed} = 1;
-        if ($file =~ /^\Q$basename\E\.orig\.tar\.$comp_regex$/) {
+        if ($file =~ /^\Q$basename\E\.orig\.tar\.$re_ext$/) {
             $tarfile = $file;
-        } elsif ($file =~ /^\Q$basename\E\.orig-([\w-]+)\.tar\.$comp_regex$/) {
+        } elsif ($file =~ /^\Q$basename\E\.orig-([\w-]+)\.tar\.$re_ext$/) {
             $origtar{$1} = $file;
-        } elsif ($file =~ /^\Q$basenamerev\E\.debian\.tar\.$comp_regex$/) {
+        } elsif ($file =~ /^\Q$basenamerev\E\.debian\.tar\.$re_ext$/) {
             $debianfile = $file;
         } else {
             error(_g("unrecognized file for a %s source package: %s"),
@@ -201,7 +202,7 @@ sub apply_patches {
 sub can_build {
     my ($self, $dir) = @_;
     foreach ($self->find_original_tarballs()) {
-        return 1 if /\.orig\.tar\.$comp_regex$/;
+        return 1 if /\.orig\.tar\.$compression_re_file_ext$/;
     }
     return (0, _g("no orig.tar file found"));
 }
@@ -250,7 +251,7 @@ sub do_build {
     my ($tarfile, %origtar);
     my @origtarballs;
     foreach (sort $self->find_original_tarballs()) {
-        if (/\.orig\.tar\.$comp_regex$/) {
+        if (/\.orig\.tar\.$compression_re_file_ext$/) {
             if (defined($tarfile)) {
                 error(_g("several orig.tar files found (%s and %s) but only " .
                          "one is allowed"), $tarfile, $_);
@@ -258,7 +259,7 @@ sub do_build {
             $tarfile = $_;
             push @origtarballs, $_;
             $self->add_file($_);
-        } elsif (/\.orig-([\w-]+)\.tar\.$comp_regex$/) {
+        } elsif (/\.orig-([\w-]+)\.tar\.$compression_re_file_ext$/) {
             $origtar{$1} = $_;
             push @origtarballs, $_;
             $self->add_file($_);

scripts/Dpkg/Source/Package/V3/bzr.pm

@@ -177,9 +177,9 @@ sub do_extract {
         error(_g("format v3.0 uses only one source file"));
     }
     my $tarfile = $files[0];
-    if ($tarfile !~ /^\Q$basenamerev\E\.bzr\.tar\.$comp_regex$/) {
+    if ($tarfile !~ /^\Q$basenamerev\E\.bzr\.tar\.$compression_re_file_ext$/) {
         error(_g("expected %s, got %s"),
-              "$basenamerev.bzr.tar.$comp_regex", $tarfile);
+              "$basenamerev.bzr.tar.$compression_re_file_ext", $tarfile);
     }
 
     erasedir($newdirectory);

scripts/Dpkg/Source/Package/V3/git.pm

@@ -241,9 +241,9 @@ sub do_extract {
 	error(_g("format v3.0 uses only one source file"));
     }
     my $tarfile = $files[0];
-    if ($tarfile !~ /^\Q$basenamerev\E\.git\.tar\.$comp_regex$/) {
+    if ($tarfile !~ /^\Q$basenamerev\E\.git\.tar\.$compression_re_file_ext$/) {
 	error(_g("expected %s, got %s"),
-	      "$basenamerev.git.tar.$comp_regex", $tarfile);
+	      "$basenamerev.git.tar.$compression_re_file_ext", $tarfile);
     }
 
     erasedir($newdirectory);

scripts/Dpkg/Source/Package/V3/native.pm

@@ -44,7 +44,7 @@ sub do_extract {
 
     my $tarfile;
     foreach my $file ($self->get_files()) {
-	if ($file =~ /^\Q$basenamerev\E\.tar\.$comp_regex$/) {
+	if ($file =~ /^\Q$basenamerev\E\.tar\.$compression_re_file_ext$/) {
             error(_g("multiple tarfiles in v1.0 source package")) if $tarfile;
             $tarfile = $file;
 	} else {
@@ -85,7 +85,7 @@ sub do_build {
 
     my ($dirname, $dirbase) = fileparse($dir);
     my $tar = Dpkg::Source::Archive->new(filename => $newtar,
-                compression => get_compression_from_filename($tarname),
+                compression => compression_guess_from_filename($tarname),
                 compression_level => $self->{'options'}{'comp_level'});
     $tar->create(options => \@tar_ignore, 'chdir' => $dirbase);
     $tar->add_directory($dirname);

scripts/dpkg-buildpackage.pl

@@ -448,11 +448,12 @@ close OUT or syserr(_g('write changes file'));
 
 my $srcmsg;
 sub fileomitted($) { return $files !~ /$_[0]/ }
+my $ext = $compression_re_file_ext;
 if (fileomitted '\.deb') {
     # source only upload
-    if (fileomitted "\.diff\.$comp_regex" and fileomitted "\.debian\.tar\.$comp_regex") {
+    if (fileomitted "\.diff\.$ext" and fileomitted "\.debian\.tar\.$ext") {
 	$srcmsg = _g('source only upload: Debian-native package');
-    } elsif (fileomitted "\.orig\.tar\.$comp_regex") {
+    } elsif (fileomitted "\.orig\.tar\.$ext") {
 	$srcmsg = _g('source only, diff-only upload (original source NOT included)');
     } else {
 	$srcmsg = _g('source only upload (original source is included)');
@@ -461,9 +462,9 @@ if (fileomitted '\.deb') {
     $srcmsg = _g('full upload (original source is included)');
     if (fileomitted '\.dsc') {
 	$srcmsg = _g('binary only upload (no source included)');
-    } elsif (fileomitted "\.diff\.$comp_regex" and fileomitted "\.debian\.tar\.$comp_regex") {
+    } elsif (fileomitted "\.diff\.$ext" and fileomitted "\.debian\.tar\.$ext") {
 	$srcmsg = _g('full upload; Debian-native package (full source is included)');
-    } elsif (fileomitted "\.orig\.tar\.$comp_regex") {
+    } elsif (fileomitted "\.orig\.tar\.$ext") {
 	$srcmsg = _g('binary and diff upload (original source NOT included)');
     } else {
 	$srcmsg = _g('full upload (original source is included)');

scripts/dpkg-genchanges.pl

@@ -440,15 +440,16 @@ if (!is_binaryonly) {
 	$include_tarball = 1;
     }
 
+    my $ext = $compression_re_file_ext;
     if ((($sourcestyle =~ m/i/ && not($include_tarball)) ||
 	 $sourcestyle =~ m/d/) &&
-	grep(m/\.(debian\.tar|diff)\.$comp_regex$/,@sourcefiles))
+	grep(m/\.(debian\.tar|diff)\.$ext$/, @sourcefiles))
     {
 	$origsrcmsg= _g("not including original source code in upload");
-	@sourcefiles= grep(!m/\.orig(-.+)?\.tar\.$comp_regex$/,@sourcefiles);
+	@sourcefiles= grep(!m/\.orig(-.+)?\.tar\.$ext$/, @sourcefiles);
     } else {
 	if ($sourcestyle =~ m/d/ &&
-	    !grep(m/\.(debian\.tar|diff)\.$comp_regex$/,@sourcefiles)) {
+	    !grep(m/\.(debian\.tar|diff)\.$ext$/, @sourcefiles)) {
 	    warning(_g("ignoring -sd option for native Debian package"));
 	}
         $origsrcmsg= _g("including full source code in upload");

scripts/dpkg-scansources.pl

@@ -160,10 +160,11 @@ sub load_src_override {
 	$file = $user_file;
     }
     elsif (defined $regular_file) {
-        my $comp = get_compression_from_filename($regular_file);
+        my $comp = compression_guess_from_filename($regular_file);
         if (defined($comp)) {
 	    $file = $regular_file;
-            $file =~ s/\.$comp_ext{$comp}$/.src.$comp_ext{$comp}/;
+	    my $ext = compression_get_property($comp, "file_ext");
+            $file =~ s/\.$ext$/.src.$ext/;
         } else {
 	    $file = "$regular_file.src";
         }

scripts/dpkg-source.pl

@@ -60,7 +60,7 @@ my %options = (
     # Compression related
     compression => $Dpkg::Compression::Compressor::default_compression,
     comp_level => $Dpkg::Compression::Compressor::default_compression_level,
-    comp_ext => $comp_ext{$Dpkg::Compression::Compressor::default_compression},
+    comp_ext => compression_get_property($Dpkg::Compression::Compressor::default_compression, "file_ext"),
     # Ignore files
     tar_ignore => [],
     diff_ignore_regexp => '',
@@ -126,9 +126,9 @@ while (@options) {
     } elsif (m/^-(?:Z|-compression=)(.*)$/) {
 	my $compression = $1;
 	$options{'compression'} = $compression;
-	$options{'comp_ext'} = $comp_ext{$compression};
+	$options{'comp_ext'} = compression_get_property($compression, "file_ext");
 	usageerr(_g("%s is not a supported compression"), $compression)
-	    unless $comp_supported{$compression};
+	    unless compression_is_supported($compression);
 	Dpkg::Compression::Compressor->set_default_compression($compression);
     } elsif (m/^-(?:z|-compression-level=)(.*)$/) {
 	my $comp_level = $1;
@@ -449,7 +449,8 @@ See dpkg-source(1) for more info.") . "\n",
     $progname,
     $Dpkg::Source::Package::diff_ignore_default_regexp,
     join(' ', map { "-I$_" } @Dpkg::Source::Package::tar_ignore_default_pattern),
-    $Dpkg::Compression::Compressor::default_compression, "@comp_supported",
+    $Dpkg::Compression::Compressor::default_compression,
+    join(" ", compression_get_list()),
     $Dpkg::Compression::Compressor::default_compression_level;
 }