chiark - git - mdw - dpkg/blob - scripts/Dpkg/Compression.pm

   1 # Copyright © 2010 Raphaël Hertzog <hertzog@debian.org>
   2 # Copyright © 2010-2013 Guillem Jover <guillem@debian.org>
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 2 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
  16
  17 package Dpkg::Compression;
  18
  19 use strict;
  20 use warnings;
  21
  22 our $VERSION = '1.02';
  23 our @EXPORT = qw(
  24     $compression_re_file_ext
  25     compression_is_supported
  26     compression_get_list
  27     compression_get_property
  28     compression_guess_from_filename
  29     compression_get_file_extension_regex
  30     compression_get_default
  31     compression_set_default
  32     compression_get_default_level
  33     compression_set_default_level
  34     compression_is_valid_level
  35 );
  36
  37 use Exporter qw(import);
  38 use Config;
  39
  40 use Dpkg::ErrorHandling;
  41 use Dpkg::Gettext;
  42
  43 =encoding utf8
  44
  45 =head1 NAME
  46
  47 Dpkg::Compression - simple database of available compression methods
  48
  49 =head1 DESCRIPTION
  50
  51 This modules provides a few public functions and a public regex to
  52 interact with the set of supported compression methods.
  53
  54 =cut
  55
  56 my $COMP = {
  57     gzip => {
  58         file_ext => 'gz',
  59         comp_prog => [ 'gzip', '--no-name' ],
  60         decomp_prog => [ 'gunzip' ],
  61         default_level => 9,
  62     },
  63     bzip2 => {
  64         file_ext => 'bz2',
  65         comp_prog => [ 'bzip2' ],
  66         decomp_prog => [ 'bunzip2' ],
  67         default_level => 9,
  68     },
  69     lzma => {
  70         file_ext => 'lzma',
  71         comp_prog => [ 'xz', '--format=lzma' ],
  72         decomp_prog => [ 'unxz', '--format=lzma' ],
  73         default_level => 6,
  74     },
  75     xz => {
  76         file_ext => 'xz',
  77         comp_prog => [ 'xz' ],
  78         decomp_prog => [ 'unxz' ],
  79         default_level => 6,
  80     },
  81 };
  82
  83 #
  84 # XXX: The gzip package in Debian at some point acquired a Debian-specific
  85 # --rsyncable option via a vendor patch. Which is not present in most of the
  86 # major distributions, dpkg downstream systems, nor gzip upstream, who have
  87 # stated they will most probably not accept it because people should be using
  88 # pigz instead.
  89 #
  90 # This option should have never been accepted in dpkg, ever. But removing it
  91 # now would probably cause demands for tarring and feathering. In addition
  92 # we cannot use the Dpkg::Vendor logic because that would cause circular
  93 # module dependencies. The whole affair is pretty disgusting really.
  94 #
  95 # Check the perl Config to discern Debian and hopefully derivatives too.
  96 #
  97 if ($Config{cf_by} eq 'Debian Project') {
  98     push @{$COMP->{gzip}->{comp_prog}}, '--rsyncable';
  99 }
 100
 101 # XXX: Backwards compatibility, stop exporting on VERSION 2.00.
 102 ## no critic (Variables::ProhibitPackageVars)
 103 our $default_compression = 'xz';
 104 our $default_compression_level = undef;
 105
 106 my $regex = join '|', map { $_->{file_ext} } values %$COMP;
 107 our $compression_re_file_ext = qr/(?:$regex)/;
 108 ## use critic
 109
 110 =head1 FUNCTIONS
 111
 112 =over 4
 113
 114 =item @list = compression_get_list()
 115
 116 Returns a list of supported compression methods (sorted alphabetically).
 117
 118 =cut
 119
 120 sub compression_get_list {
 121     my @list = sort keys %$COMP;
 122     return @list;
 123 }
 124
 125 =item compression_is_supported($comp)
 126
 127 Returns a boolean indicating whether the give compression method is
 128 known and supported.
 129
 130 =cut
 131
 132 sub compression_is_supported {
 133     my $comp = shift;
 134
 135     return exists $COMP->{$comp};
 136 }
 137
 138 =item compression_get_property($comp, $property)
 139
 140 Returns the requested property of the compression method. Returns undef if
 141 either the property or the compression method doesn't exist. Valid
 142 properties currently include "file_ext" for the file extension,
 143 "default_level" for the default compression level,
 144 "comp_prog" for the name of the compression program and "decomp_prog" for
 145 the name of the decompression program.
 146
 147 =cut
 148
 149 sub compression_get_property {
 150     my ($comp, $property) = @_;
 151     return unless compression_is_supported($comp);
 152     return $COMP->{$comp}{$property} if exists $COMP->{$comp}{$property};
 153     return;
 154 }
 155
 156 =item compression_guess_from_filename($filename)
 157
 158 Returns the compression method that is likely used on the indicated
 159 filename based on its file extension.
 160
 161 =cut
 162
 163 sub compression_guess_from_filename {
 164     my $filename = shift;
 165     foreach my $comp (compression_get_list()) {
 166         my $ext = compression_get_property($comp, 'file_ext');
 167         if ($filename =~ /^(.*)\.\Q$ext\E$/) {
 168             return $comp;
 169         }
 170     }
 171     return;
 172 }
 173
 174 =item $regex = compression_get_file_extension_regex()
 175
 176 Returns a regex that matches a file extension of a file compressed with
 177 one of the supported compression methods.
 178
 179 =cut
 180
 181 sub compression_get_file_extension_regex {
 182     return $compression_re_file_ext;
 183 }
 184
 185 =item $comp = compression_get_default()
 186
 187 Return the default compression method. It is "xz" unless
 188 C<compression_set_default> has been used to change it.
 189
 190 =item compression_set_default($comp)
 191
 192 Change the default compression method. Errors out if the
 193 given compression method is not supported.
 194
 195 =cut
 196
 197 sub compression_get_default {
 198     return $default_compression;
 199 }
 200
 201 sub compression_set_default {
 202     my $method = shift;
 203     error(g_('%s is not a supported compression'), $method)
 204             unless compression_is_supported($method);
 205     $default_compression = $method;
 206 }
 207
 208 =item $level = compression_get_default_level()
 209
 210 Return the default compression level used when compressing data. It's "9"
 211 for "gzip" and "bzip2", "6" for "xz" and "lzma", unless
 212 C<compression_set_default_level> has been used to change it.
 213
 214 =item compression_set_default_level($level)
 215
 216 Change the default compression level. Passing undef as the level will
 217 reset it to the compressor specific default, otherwise errors out if the
 218 level is not valid (see C<compression_is_valid_level>).
 219
 220 =cut
 221
 222 sub compression_get_default_level {
 223     if (defined $default_compression_level) {
 224         return $default_compression_level;
 225     } else {
 226         return compression_get_property($default_compression, 'default_level');
 227     }
 228 }
 229
 230 sub compression_set_default_level {
 231     my $level = shift;
 232     error(g_('%s is not a compression level'), $level)
 233         if defined($level) and not compression_is_valid_level($level);
 234     $default_compression_level = $level;
 235 }
 236
 237 =item compression_is_valid_level($level)
 238
 239 Returns a boolean indicating whether $level is a valid compression level
 240 (it must be either a number between 1 and 9 or "fast" or "best")
 241
 242 =cut
 243
 244 sub compression_is_valid_level {
 245     my $level = shift;
 246     return $level =~ /^([1-9]|fast|best)$/;
 247 }
 248
 249 =back
 250
 251 =head1 CHANGES
 252
 253 =head2 Version 1.02 (dpkg 1.17.2)
 254
 255 New function: compression_get_file_extension_regex()
 256
 257 Deprecated variables: $default_compression, $default_compression_level
 258 and $compression_re_file_ext
 259
 260 =head2 Version 1.01 (dpkg 1.16.1)
 261
 262 Default compression level is not global any more, it is per compressor type.
 263
 264 =head2 Version 1.00 (dpkg 1.15.6)
 265
 266 Mark the module as public.
 267
 268 =cut
 269
 270 1;