File Coverage

File:Dpkg/Compression.pm
Coverage:87.8%

linestmtbrancondsubpodtimecode
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
19
27
27
27
27
60
24
294
use strict;
20
27
27
27
27
36
23
919
use warnings;
21
22our $VERSION = '2.00';
23our @EXPORT = qw(
24    compression_is_supported
25    compression_get_list
26    compression_get_property
27    compression_guess_from_filename
28    compression_get_file_extension_regex
29    compression_get_default
30    compression_set_default
31    compression_get_default_level
32    compression_set_default_level
33    compression_is_valid_level
34);
35
36
27
27
27
27
60
22
296
use Exporter qw(import);
37
27
27
27
27
42
13
408
use Config;
38
27
27
27
27
52
12
610
use List::Util qw(any);
39
40
27
27
27
27
853
27
758
use Dpkg::ErrorHandling;
41
27
27
27
27
55
23
7718
use Dpkg::Gettext;
42
43=encoding utf8
44
45 - 54
=head1 NAME

Dpkg::Compression - simple database of available compression methods

=head1 DESCRIPTION

This modules provides a few public functions and a public regex to
interact with the set of supported compression methods.

=cut
55
56my $COMP = {
57    gzip => {
58        file_ext => 'gz',
59        comp_prog => [ 'gzip', '-n' ],
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# The gzip --rsyncable option is not universally supported, so we need to
84# conditionally use it. Ideally we would invoke 'gzip --help' and check
85# whether the option is supported, but that would imply forking and executing
86# that process for any module that ends up loading this one, which is not
87# acceptable performance-wise. Instead we will approximate it by osname, which
88# is not ideal, but better than nothing.
89#
90# Requires GNU gzip >= 1.7 for the --rsyncable option. On AIX GNU gzip is
91# too old. On the BSDs they use their own implementation based on zlib,
92# which does not currently support the --rsyncable option.
93if (any { $Config{osname} eq $_ } qw(linux gnu solaris)) {
94    push @{$COMP->{gzip}->{comp_prog}}, '--rsyncable';
95}
96
97my $default_compression = 'xz';
98my $default_compression_level = undef;
99
100my $regex = join '|', map { $_->{file_ext} } values %$COMP;
101my $compression_re_file_ext = qr/(?:$regex)/;
102
103 - 111
=head1 FUNCTIONS

=over 4

=item @list = compression_get_list()

Returns a list of supported compression methods (sorted alphabetically).

=cut
112
113sub compression_get_list {
114
173
173
1
518
    my @list = sort keys %$COMP;
115
173
281
    return @list;
116}
117
118 - 123
=item compression_is_supported($comp)

Returns a boolean indicating whether the give compression method is
known and supported.

=cut
124
125sub compression_is_supported {
126
1038
1038
1
678
    my $comp = shift;
127
128
1038
1183
    return exists $COMP->{$comp};
129}
130
131 - 140
=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,
"default_level" for the default compression level,
"comp_prog" for the name of the compression program and "decomp_prog" for
the name of the decompression program.

=cut
141
142sub compression_get_property {
143
856
856
1
686
    my ($comp, $property) = @_;
144
856
50
603
    return unless compression_is_supported($comp);
145
856
50
1584
    return $COMP->{$comp}{$property} if exists $COMP->{$comp}{$property};
146
0
0
    return;
147}
148
149 - 154
=item compression_guess_from_filename($filename)

Returns the compression method that is likely used on the indicated
filename based on its file extension.

=cut
155
156sub compression_guess_from_filename {
157
173
173
1
134
    my $filename = shift;
158
173
186
    foreach my $comp (compression_get_list()) {
159
664
560
        my $ext = compression_get_property($comp, 'file_ext');
160
664
100
4504
        if ($filename =~ /^(.*)\.\Q$ext\E$/) {
161
14
28
            return $comp;
162        }
163    }
164
159
195
    return;
165}
166
167 - 172
=item $regex = compression_get_file_extension_regex()

Returns a regex that matches a file extension of a file compressed with
one of the supported compression methods.

=cut
173
174sub compression_get_file_extension_regex {
175
168
168
1
170
    return $compression_re_file_ext;
176}
177
178 - 188
=item $comp = compression_get_default()

Return the default compression method. It is "xz" unless
C<compression_set_default> has been used to change it.

=item compression_set_default($comp)

Change the default compression method. Errors out if the
given compression method is not supported.

=cut
189
190sub compression_get_default {
191
168
168
1
429
    return $default_compression;
192}
193
194sub compression_set_default {
195
0
0
1
0
    my $method = shift;
196
0
0
0
    error(g_('%s is not a supported compression'), $method)
197            unless compression_is_supported($method);
198
0
0
    $default_compression = $method;
199}
200
201 - 213
=item $level = compression_get_default_level()

Return the default compression level used when compressing data. It's "9"
for "gzip" and "bzip2", "6" for "xz" and "lzma", unless
C<compression_set_default_level> has been used to change it.

=item compression_set_default_level($level)

Change the default compression level. Passing undef as the level will
reset it to the compressor specific default, otherwise errors out if the
level is not valid (see C<compression_is_valid_level>).

=cut
214
215sub compression_get_default_level {
216
188
100
188
1
213
    if (defined $default_compression_level) {
217
10
25
        return $default_compression_level;
218    } else {
219
178
199
        return compression_get_property($default_compression, 'default_level');
220    }
221}
222
223sub compression_set_default_level {
224
15
15
1
15
    my $level = shift;
225
15
50
67
25
    error(g_('%s is not a compression level'), $level)
226        if defined($level) and not compression_is_valid_level($level);
227
15
15
    $default_compression_level = $level;
228}
229
230 - 235
=item compression_is_valid_level($level)

Returns a boolean indicating whether $level is a valid compression level
(it must be either a number between 1 and 9 or "fast" or "best")

=cut
236
237sub compression_is_valid_level {
238
178
178
1
131
    my $level = shift;
239
178
573
    return $level =~ /^([1-9]|fast|best)$/;
240}
241
242=back
243
244 - 266
=head1 CHANGES

=head2 Version 2.00 (dpkg 1.20.0)

Hide variables: $default_compression, $default_compression_level
and $compression_re_file_ext.

=head2 Version 1.02 (dpkg 1.17.2)

New function: compression_get_file_extension_regex()

Deprecated variables: $default_compression, $default_compression_level
and $compression_re_file_ext

=head2 Version 1.01 (dpkg 1.16.1)

Default compression level is not global any more, it is per compressor type.

=head2 Version 1.00 (dpkg 1.15.6)

Mark the module as public.

=cut
267
2681;