OLD | NEW |
(Empty) | |
| 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 |
| 24 use Dpkg::ErrorHandling; |
| 25 use Dpkg::Gettext; |
| 26 |
| 27 use Exporter qw(import); |
| 28 our @EXPORT = qw($compression_re_file_ext compression_get_list |
| 29 compression_is_supported compression_get_property |
| 30 compression_guess_from_filename |
| 31 compression_get_file_extension_regex |
| 32 compression_get_default compression_set_default |
| 33 compression_get_default_level |
| 34 compression_set_default_level |
| 35 compression_is_valid_level); |
| 36 |
| 37 =encoding utf8 |
| 38 |
| 39 =head1 NAME |
| 40 |
| 41 Dpkg::Compression - simple database of available compression methods |
| 42 |
| 43 =head1 DESCRIPTION |
| 44 |
| 45 This modules provides a few public funcions and a public regex to |
| 46 interact with the set of supported compression methods. |
| 47 |
| 48 =cut |
| 49 |
| 50 my $COMP = { |
| 51 gzip => { |
| 52 file_ext => 'gz', |
| 53 comp_prog => [ 'gzip', '--no-name', '--rsyncable' ], |
| 54 decomp_prog => [ 'gunzip' ], |
| 55 default_level => 9, |
| 56 }, |
| 57 bzip2 => { |
| 58 file_ext => 'bz2', |
| 59 comp_prog => [ 'bzip2' ], |
| 60 decomp_prog => [ 'bunzip2' ], |
| 61 default_level => 9, |
| 62 }, |
| 63 lzma => { |
| 64 file_ext => 'lzma', |
| 65 comp_prog => [ 'xz', '--format=lzma' ], |
| 66 decomp_prog => [ 'unxz', '--format=lzma' ], |
| 67 default_level => 6, |
| 68 }, |
| 69 xz => { |
| 70 file_ext => 'xz', |
| 71 comp_prog => [ 'xz' ], |
| 72 decomp_prog => [ 'unxz' ], |
| 73 default_level => 6, |
| 74 }, |
| 75 }; |
| 76 |
| 77 # XXX: Backwards compatibility, stop exporting on VERSION 2.00. |
| 78 ## no critic (Variables::ProhibitPackageVars) |
| 79 our $default_compression = 'gzip'; |
| 80 our $default_compression_level = undef; |
| 81 |
| 82 my $regex = join '|', map { $_->{file_ext} } values %$COMP; |
| 83 our $compression_re_file_ext = qr/(?:$regex)/; |
| 84 ## use critic |
| 85 |
| 86 =head1 EXPORTED FUNCTIONS |
| 87 |
| 88 =over 4 |
| 89 |
| 90 =item my @list = compression_get_list() |
| 91 |
| 92 Returns a list of supported compression methods (sorted alphabetically). |
| 93 |
| 94 =cut |
| 95 |
| 96 sub compression_get_list { |
| 97 my @list = sort keys %$COMP; |
| 98 return @list; |
| 99 } |
| 100 |
| 101 =item compression_is_supported($comp) |
| 102 |
| 103 Returns a boolean indicating whether the give compression method is |
| 104 known and supported. |
| 105 |
| 106 =cut |
| 107 |
| 108 sub compression_is_supported { |
| 109 return exists $COMP->{$_[0]}; |
| 110 } |
| 111 |
| 112 =item compression_get_property($comp, $property) |
| 113 |
| 114 Returns the requested property of the compression method. Returns undef if |
| 115 either the property or the compression method doesn't exist. Valid |
| 116 properties currently include "file_ext" for the file extension, |
| 117 "default_level" for the default compression level, |
| 118 "comp_prog" for the name of the compression program and "decomp_prog" for |
| 119 the name of the decompression program. |
| 120 |
| 121 =cut |
| 122 |
| 123 sub compression_get_property { |
| 124 my ($comp, $property) = @_; |
| 125 return unless compression_is_supported($comp); |
| 126 return $COMP->{$comp}{$property} if exists $COMP->{$comp}{$property}; |
| 127 return; |
| 128 } |
| 129 |
| 130 =item compression_guess_from_filename($filename) |
| 131 |
| 132 Returns the compression method that is likely used on the indicated |
| 133 filename based on its file extension. |
| 134 |
| 135 =cut |
| 136 |
| 137 sub compression_guess_from_filename { |
| 138 my $filename = shift; |
| 139 foreach my $comp (compression_get_list()) { |
| 140 my $ext = compression_get_property($comp, 'file_ext'); |
| 141 if ($filename =~ /^(.*)\.\Q$ext\E$/) { |
| 142 return $comp; |
| 143 } |
| 144 } |
| 145 return; |
| 146 } |
| 147 |
| 148 =item my $regex = compression_get_file_extension_regex() |
| 149 |
| 150 Returns a regex that matches a file extension of a file compressed with |
| 151 one of the supported compression methods. |
| 152 |
| 153 =cut |
| 154 |
| 155 sub compression_get_file_extension_regex { |
| 156 return $compression_re_file_ext; |
| 157 } |
| 158 |
| 159 =item my $comp = compression_get_default() |
| 160 |
| 161 Return the default compression method. It's "gzip" unless |
| 162 C<compression_set_default> has been used to change it. |
| 163 |
| 164 =item compression_set_default($comp) |
| 165 |
| 166 Change the default compression method. Errors out if the |
| 167 given compression method is not supported. |
| 168 |
| 169 =cut |
| 170 |
| 171 sub compression_get_default { |
| 172 return $default_compression; |
| 173 } |
| 174 |
| 175 sub compression_set_default { |
| 176 my ($method) = @_; |
| 177 error(_g('%s is not a supported compression'), $method) |
| 178 unless compression_is_supported($method); |
| 179 $default_compression = $method; |
| 180 } |
| 181 |
| 182 =item my $level = compression_get_default_level() |
| 183 |
| 184 Return the default compression level used when compressing data. It's "9" |
| 185 for "gzip" and "bzip2", "6" for "xz" and "lzma", unless |
| 186 C<compression_set_default_level> has been used to change it. |
| 187 |
| 188 =item compression_set_default_level($level) |
| 189 |
| 190 Change the default compression level. Passing undef as the level will |
| 191 reset it to the compressor specific default, otherwise errors out if the |
| 192 level is not valid (see C<compression_is_valid_level>). |
| 193 |
| 194 =cut |
| 195 |
| 196 sub compression_get_default_level { |
| 197 if (defined $default_compression_level) { |
| 198 return $default_compression_level; |
| 199 } else { |
| 200 return compression_get_property($default_compression, 'default_level'); |
| 201 } |
| 202 } |
| 203 |
| 204 sub compression_set_default_level { |
| 205 my ($level) = @_; |
| 206 error(_g('%s is not a compression level'), $level) |
| 207 if defined($level) and not compression_is_valid_level($level); |
| 208 $default_compression_level = $level; |
| 209 } |
| 210 |
| 211 =item compression_is_valid_level($level) |
| 212 |
| 213 Returns a boolean indicating whether $level is a valid compression level |
| 214 (it must be either a number between 1 and 9 or "fast" or "best") |
| 215 |
| 216 =cut |
| 217 |
| 218 sub compression_is_valid_level { |
| 219 my ($level) = @_; |
| 220 return $level =~ /^([1-9]|fast|best)$/; |
| 221 } |
| 222 |
| 223 =back |
| 224 |
| 225 =head1 CHANGES |
| 226 |
| 227 =head2 Version 1.02 |
| 228 |
| 229 New function: compression_get_file_extension_regex() |
| 230 |
| 231 Deprecated variables: $default_compression, $default_compression_level |
| 232 and $compression_re_file_ext |
| 233 |
| 234 =head2 Version 1.01 |
| 235 |
| 236 Default compression level is not global any more, it is per compressor type. |
| 237 |
| 238 =head1 AUTHOR |
| 239 |
| 240 Raphaël Hertzog <hertzog@debian.org>. |
| 241 |
| 242 =cut |
| 243 |
| 244 1; |
OLD | NEW |