File Coverage

File:Dpkg/Compression.pm
Coverage:77.6%

linestmtbrancondsubpodtimecode
1# Copyright © 2007-2022 Guillem Jover <guillem@debian.org>
2# Copyright © 2010 Raphaël Hertzog <hertzog@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=encoding utf8
18
19 - 28
=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
29
30package Dpkg::Compression 2.01;
31
32
84
84
84
232
68
1299
use strict;
33
84
84
84
160
62
3809
use warnings;
34
35our @EXPORT = qw(
36    compression_is_supported
37    compression_get_list
38    compression_get_property
39    compression_guess_from_filename
40    compression_get_file_extension_regex
41    compression_get_file_extension
42    compression_get_default
43    compression_set_default
44    compression_get_default_level
45    compression_set_default_level
46    compression_get_level
47    compression_set_level
48    compression_is_valid_level
49    compression_get_threads
50    compression_set_threads
51    compression_get_cmdline_compress
52    compression_get_cmdline_decompress
53);
54
55
84
84
84
193
66
1308
use Exporter qw(import);
56
84
84
84
172
72
1813
use Config;
57
84
84
84
174
64
2600
use List::Util qw(any);
58
59
84
84
84
3190
75
2911
use Dpkg::ErrorHandling;
60
84
84
84
175
67
53705
use Dpkg::Gettext;
61
62my %COMP = (
63    gzip => {
64        file_ext => 'gz',
65        comp_prog => [ 'gzip', '-n' ],
66        decomp_prog => [ 'gunzip' ],
67        default_level => 9,
68    },
69    bzip2 => {
70        file_ext => 'bz2',
71        comp_prog => [ 'bzip2' ],
72        decomp_prog => [ 'bunzip2' ],
73        default_level => 9,
74    },
75    lzma => {
76        file_ext => 'lzma',
77        comp_prog => [ 'xz', '--format=lzma' ],
78        decomp_prog => [ 'unxz', '--format=lzma' ],
79        default_level => 6,
80    },
81    xz => {
82        file_ext => 'xz',
83        comp_prog => [ 'xz' ],
84        decomp_prog => [ 'unxz' ],
85        default_level => 6,
86    },
87);
88
89# The gzip --rsyncable option is not universally supported, so we need to
90# conditionally use it. Ideally we would invoke 'gzip --help' and check
91# whether the option is supported, but that would imply forking and executing
92# that process for any module that ends up loading this one, which is not
93# acceptable performance-wise. Instead we will approximate it by osname, which
94# is not ideal, but better than nothing.
95#
96# Requires GNU gzip >= 1.7 for the --rsyncable option. On AIX GNU gzip is
97# too old. On the BSDs they use their own implementation based on zlib,
98# which does not currently support the --rsyncable option.
99if (any { $Config{osname} eq $_ } qw(linux gnu solaris)) {
100    push @{$COMP{gzip}{comp_prog}}, '--rsyncable';
101}
102
103my $default_compression = 'xz';
104my $default_compression_level = undef;
105my $default_compression_threads = 0;
106
107my $regex = join '|', map { $_->{file_ext} } values %COMP;
108my $compression_re_file_ext = qr/(?:$regex)/;
109
110 - 118
=head1 FUNCTIONS

=over 4

=item @list = compression_get_list()

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

=cut
119
120sub compression_get_list {
121
633
1
2125
    my @list = sort keys %COMP;
122
633
1211
    return @list;
123}
124
125 - 130
=item compression_is_supported($comp)

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

=cut
131
132sub compression_is_supported {
133
1452
1
1147
    my $comp = shift;
134
135
1452
2624
    return exists $COMP{$comp};
136}
137
138 - 150
=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.

This function is deprecated, please switch to one of the new specialized
getters instead.

=cut
151
152sub compression_get_property {
153
0
1
0
    my ($comp, $property) = @_;
154
155    #warnings::warnif('deprecated',
156    #    'Dpkg::Compression::compression_get_property() is deprecated, ' .
157    #    'use one of the specialized getters instead');
158
0
0
    return unless compression_is_supported($comp);
159
0
0
    return $COMP{$comp}{$property} if exists $COMP{$comp}{$property};
160
0
0
    return;
161}
162
163 - 168
=item compression_guess_from_filename($filename)

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

=cut
169
170sub compression_guess_from_filename {
171
618
1
520
    my $filename = shift;
172
618
815
    foreach my $comp (compression_get_list()) {
173
2298
2430
        my $ext = $COMP{$comp}{file_ext};
174
2298
19076
        if ($filename =~ /^(.*)\.\Q$ext\E$/) {
175
102
184
            return $comp;
176        }
177    }
178
516
829
    return;
179}
180
181 - 186
=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
187
188sub compression_get_file_extension_regex {
189
543
1
642
    return $compression_re_file_ext;
190}
191
192 - 196
=item $ext = compression_get_file_extension($comp)

Return the file extension for the compressor $comp.

=cut
197
198sub compression_get_file_extension {
199
60
1
45
    my $comp = shift;
200
201
60
45
    error(g_('%s is not a supported compression'), $comp)
202        unless compression_is_supported($comp);
203
204
60
85
    return $COMP{$comp}{file_ext};
205}
206
207 - 212
=item $comp = compression_get_default()

Return the default compression method. It is "xz" unless
compression_set_default() has been used to change it.

=cut
213
214sub compression_get_default {
215
588
1
1705
    return $default_compression;
216}
217
218 - 223
=item compression_set_default($comp)

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

=cut
224
225sub compression_set_default {
226
45
1
35
    my $method = shift;
227
45
40
    error(g_('%s is not a supported compression'), $method)
228        unless compression_is_supported($method);
229
30
35
    $default_compression = $method;
230}
231
232 - 240
=item $level = compression_get_default_level()

Return the global default compression level used when compressing data if
it has been set, otherwise the default level for the default compressor.

It's "9" for "gzip" and "bzip2", "6" for "xz" and "lzma", unless
compression_set_default_level() has been used to change it.

=cut
241
242sub compression_get_default_level {
243
588
1
849
    if (defined $default_compression_level) {
244
30
40
        return $default_compression_level;
245    } else {
246
558
1811
        return $COMP{$default_compression}{default_level};
247    }
248}
249
250 - 256
=item compression_set_default_level($level)

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

=cut
257
258sub compression_set_default_level {
259
45
1
35
    my $level = shift;
260
45
100
    error(g_('%s is not a compression level'), $level)
261        if defined($level) and not compression_is_valid_level($level);
262
45
25
    $default_compression_level = $level;
263}
264
265 - 272
=item $level = compression_get_level($comp)

Return the compression level used when compressing data with a specific
compressor. The value returned is the specific compression level if it has
been set, otherwise the global default compression level if it has been set,
falling back to the specific default compression level.

=cut
273
274sub compression_get_level {
275
117
1
153
    my $comp = shift;
276
277
117
96
    error(g_('%s is not a supported compression'), $comp)
278        unless compression_is_supported($comp);
279
280    return $COMP{$comp}{level} //
281           $default_compression_level //
282
117
432
           $COMP{$comp}{default_level};
283}
284
285 - 291
=item compression_set_level($comp, $level)

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

=cut
292
293sub compression_set_level {
294
558
1
728
    my ($comp, $level) = @_;
295
296
558
610
    error(g_('%s is not a supported compression'), $comp)
297        unless compression_is_supported($comp);
298
558
1523
    error(g_('%s is not a compression level'), $level)
299        if defined $level && ! compression_is_valid_level($level);
300
301
558
984
    $COMP{$comp}{level} = $level;
302}
303
304 - 309
=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
310
311sub compression_is_valid_level {
312
663
1
616
    my $level = shift;
313
663
2990
    return $level =~ /^([1-9]|fast|best)$/;
314}
315
316 - 320
=item $threads = compression_get_threads()

Return the number of threads to use for compression and decompression.

=cut
321
322sub compression_get_threads {
323
42
1
48
    return $default_compression_threads;
324}
325
326 - 332
=item compression_set_threads($threads)

Change the threads to use for compression and decompression. Passing C<undef>
or B<0> requests to use automatic mode, based on the current CPU cores on
the system.

=cut
333
334sub compression_set_threads {
335
0
1
0
    my $threads = shift;
336
337
0
0
    error(g_('compression threads %s is not a number'), $threads)
338        if defined $threads && $threads !~ m/^\d+$/;
339
0
0
    $default_compression_threads = $threads;
340}
341
342 - 351
=item @exec = compression_get_cmdline_compress($comp)

Returns a list ready to be passed to exec(), its first element is the
program name for compression and the following elements are parameters
for the program.

When executed the program will act as a filter between its standard input
and its standard output.

=cut
352
353sub compression_get_cmdline_compress {
354
27
1
18
    my $comp = shift;
355
356
27
37
    error(g_('%s is not a supported compression'), $comp)
357        unless compression_is_supported($comp);
358
359
27
27
23
70
    my @prog = @{$COMP{$comp}{comp_prog}};
360
27
39
    my $level = compression_get_level($comp);
361
27
54
    if ($level =~ m/^[1-9]$/) {
362
27
37
        push @prog, "-$level";
363    } else {
364
0
0
        push @prog, "--$level";
365    }
366
27
22
    my $threads = compression_get_threads();
367
27
57
    if ($comp eq 'xz') {
368        # Do not generate warnings when adjusting memory usage, nor
369        # exit with non-zero due to those not emitted warnings.
370
0
0
        push @prog, qw(--quiet --no-warn);
371
372        # Do not let xz fallback to single-threaded mode, to avoid
373        # non-reproducible output.
374
0
0
        push @prog, '--no-adjust';
375
376        # The xz -T1 option selects a single-threaded mode which generates
377        # different output than in multi-threaded mode. To avoid the
378        # non-reproducible output we pass -T+1 (supported with xz >= 5.4.0)
379        # to request multi-threaded mode with a single thread.
380
0
0
        push @prog, $threads == 1 ? '-T+1' : "-T$threads";
381    }
382
27
50
    return @prog;
383}
384
385 - 394
=item @exec = compression_get_cmdline_decompress($comp)

Returns a list ready to be passed to exec(), its first element is the
program name for decompression and the following elements are parameters
for the program.

When executed the program will act as a filter between its standard input
and its standard output.

=cut
395
396sub compression_get_cmdline_decompress {
397
15
1
10
    my $comp = shift;
398
399
15
19
    error(g_('%s is not a supported compression'), $comp)
400        unless compression_is_supported($comp);
401
402
15
15
10
41
    my @prog = @{$COMP{$comp}{decomp_prog}};
403
404
15
18
    my $threads = compression_get_threads();
405
15
19
    if ($comp eq 'xz') {
406
0
0
        push @prog, "-T$threads";
407    }
408
409
15
17
    return @prog;
410}
411
412=back
413
414 - 445
=head1 CHANGES

=head2 Version 2.01 (dpkg 1.21.14)

New functions: compression_get_file_extension(), compression_get_level(),
compression_set_level(), compression_get_cmdline_compress(),
compression_get_cmdline_decompress(), compression_get_threads() and
compression_set_threads().

Deprecated functions: compression_get_property().

=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
446
4471;