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 17package Dpkg::Compression; 18 19use strict; 20use warnings; 21 22our $VERSION = '1.02'; 23our @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 37use Exporter qw(import); 38use Config; 39 40use Dpkg::ErrorHandling; 41use Dpkg::Gettext; 42 43=encoding utf8 44 45=head1 NAME 46 47Dpkg::Compression - simple database of available compression methods 48 49=head1 DESCRIPTION 50 51This modules provides a few public functions and a public regex to 52interact with the set of supported compression methods. 53 54=cut 55 56my $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# 97if ($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) 103our $default_compression = 'xz'; 104our $default_compression_level = undef; 105 106my $regex = join '|', map { $_->{file_ext} } values %$COMP; 107our $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 116Returns a list of supported compression methods (sorted alphabetically). 117 118=cut 119 120sub compression_get_list { 121 my @list = sort keys %$COMP; 122 return @list; 123} 124 125=item compression_is_supported($comp) 126 127Returns a boolean indicating whether the give compression method is 128known and supported. 129 130=cut 131 132sub compression_is_supported { 133 my $comp = shift; 134 135 return exists $COMP->{$comp}; 136} 137 138=item compression_get_property($comp, $property) 139 140Returns the requested property of the compression method. Returns undef if 141either the property or the compression method doesn't exist. Valid 142properties 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 145the name of the decompression program. 146 147=cut 148 149sub 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 158Returns the compression method that is likely used on the indicated 159filename based on its file extension. 160 161=cut 162 163sub 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 176Returns a regex that matches a file extension of a file compressed with 177one of the supported compression methods. 178 179=cut 180 181sub compression_get_file_extension_regex { 182 return $compression_re_file_ext; 183} 184 185=item $comp = compression_get_default() 186 187Return the default compression method. It is "xz" unless 188C<compression_set_default> has been used to change it. 189 190=item compression_set_default($comp) 191 192Change the default compression method. Errors out if the 193given compression method is not supported. 194 195=cut 196 197sub compression_get_default { 198 return $default_compression; 199} 200 201sub 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 210Return the default compression level used when compressing data. It's "9" 211for "gzip" and "bzip2", "6" for "xz" and "lzma", unless 212C<compression_set_default_level> has been used to change it. 213 214=item compression_set_default_level($level) 215 216Change the default compression level. Passing undef as the level will 217reset it to the compressor specific default, otherwise errors out if the 218level is not valid (see C<compression_is_valid_level>). 219 220=cut 221 222sub 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 230sub 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 239Returns 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 244sub 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 255New function: compression_get_file_extension_regex() 256 257Deprecated variables: $default_compression, $default_compression_level 258and $compression_re_file_ext 259 260=head2 Version 1.01 (dpkg 1.16.1) 261 262Default compression level is not global any more, it is per compressor type. 263 264=head2 Version 1.00 (dpkg 1.15.6) 265 266Mark the module as public. 267 268=cut 269 2701; 271