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