File Coverage

blib/lib/Dpkg/Compression.pm
Criterion Covered Total %
statement 41 45 91.1
branch 7 12 58.3
condition 2 3 66.6
subroutine 15 16 93.7
pod 10 10 100.0
total 75 86 87.2


line stmt bran cond sub pod time code
1             # Copyright © 2010 Raphaël Hertzog
2             # Copyright © 2010-2013 Guillem Jover
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 .
16              
17             package Dpkg::Compression;
18              
19 20     20   4360 use strict;
  20         40  
  20         603  
20 20     20   97 use warnings;
  20         95  
  20         1299  
21              
22             our $VERSION = '2.00';
23             our @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 20     20   131 use Exporter qw(import);
  20         103  
  20         680  
37 20     20   117 use Config;
  20         30  
  20         961  
38              
39 20     20   2423 use Dpkg::ErrorHandling;
  20         71  
  20         1727  
40 20     20   170 use Dpkg::Gettext;
  20         84  
  20         14719  
41              
42             =encoding utf8
43              
44             =head1 NAME
45              
46             Dpkg::Compression - simple database of available compression methods
47              
48             =head1 DESCRIPTION
49              
50             This modules provides a few public functions and a public regex to
51             interact with the set of supported compression methods.
52              
53             =cut
54              
55             my $COMP = {
56             gzip => {
57             file_ext => 'gz',
58             comp_prog => [ 'gzip', '--no-name' ],
59             decomp_prog => [ 'gunzip' ],
60             default_level => 9,
61             },
62             bzip2 => {
63             file_ext => 'bz2',
64             comp_prog => [ 'bzip2' ],
65             decomp_prog => [ 'bunzip2' ],
66             default_level => 9,
67             },
68             lzma => {
69             file_ext => 'lzma',
70             comp_prog => [ 'xz', '--format=lzma' ],
71             decomp_prog => [ 'unxz', '--format=lzma' ],
72             default_level => 6,
73             },
74             xz => {
75             file_ext => 'xz',
76             comp_prog => [ 'xz' ],
77             decomp_prog => [ 'unxz' ],
78             default_level => 6,
79             },
80             };
81              
82             #
83             # XXX: The gzip package in Debian at some point acquired a Debian-specific
84             # --rsyncable option via a vendor patch. Which is not present in most of the
85             # major distributions, dpkg downstream systems, nor gzip upstream, who have
86             # stated they will most probably not accept it because people should be using
87             # pigz instead.
88             #
89             # This option should have never been accepted in dpkg, ever. But removing it
90             # now would probably cause demands for tarring and feathering. In addition
91             # we cannot use the Dpkg::Vendor logic because that would cause circular
92             # module dependencies. The whole affair is pretty disgusting really.
93             #
94             # Check the perl Config to discern Debian and hopefully derivatives too.
95             #
96             if ($Config{cf_by} eq 'Debian Project') {
97             push @{$COMP->{gzip}->{comp_prog}}, '--rsyncable';
98             }
99              
100             my $default_compression = 'xz';
101             my $default_compression_level = undef;
102              
103             my $regex = join '|', map { $_->{file_ext} } values %$COMP;
104             my $compression_re_file_ext = qr/(?:$regex)/;
105              
106             =head1 FUNCTIONS
107              
108             =over 4
109              
110             =item @list = compression_get_list()
111              
112             Returns a list of supported compression methods (sorted alphabetically).
113              
114             =cut
115              
116             sub compression_get_list {
117 159     159 1 1111 my @list = sort keys %$COMP;
118 159         641 return @list;
119             }
120              
121             =item compression_is_supported($comp)
122              
123             Returns a boolean indicating whether the give compression method is
124             known and supported.
125              
126             =cut
127              
128             sub compression_is_supported {
129 954     954 1 1702 my $comp = shift;
130              
131 954         2691 return exists $COMP->{$comp};
132             }
133              
134             =item compression_get_property($comp, $property)
135              
136             Returns the requested property of the compression method. Returns undef if
137             either the property or the compression method doesn't exist. Valid
138             properties currently include "file_ext" for the file extension,
139             "default_level" for the default compression level,
140             "comp_prog" for the name of the compression program and "decomp_prog" for
141             the name of the decompression program.
142              
143             =cut
144              
145             sub compression_get_property {
146 786     786 1 1613 my ($comp, $property) = @_;
147 786 50       1270 return unless compression_is_supported($comp);
148 786 50       3296 return $COMP->{$comp}{$property} if exists $COMP->{$comp}{$property};
149 0         0 return;
150             }
151              
152             =item compression_guess_from_filename($filename)
153              
154             Returns the compression method that is likely used on the indicated
155             filename based on its file extension.
156              
157             =cut
158              
159             sub compression_guess_from_filename {
160 159     159 1 328 my $filename = shift;
161 159         1277 foreach my $comp (compression_get_list()) {
162 608         1365 my $ext = compression_get_property($comp, 'file_ext');
163 608 100       10078 if ($filename =~ /^(.*)\.\Q$ext\E$/) {
164 14         67 return $comp;
165             }
166             }
167 145         494 return;
168             }
169              
170             =item $regex = compression_get_file_extension_regex()
171              
172             Returns a regex that matches a file extension of a file compressed with
173             one of the supported compression methods.
174              
175             =cut
176              
177             sub compression_get_file_extension_regex {
178 154     154 1 382 return $compression_re_file_ext;
179             }
180              
181             =item $comp = compression_get_default()
182              
183             Return the default compression method. It is "xz" unless
184             C has been used to change it.
185              
186             =item compression_set_default($comp)
187              
188             Change the default compression method. Errors out if the
189             given compression method is not supported.
190              
191             =cut
192              
193             sub compression_get_default {
194 154     154 1 785 return $default_compression;
195             }
196              
197             sub compression_set_default {
198 0     0 1 0 my $method = shift;
199 0 0       0 error(g_('%s is not a supported compression'), $method)
200             unless compression_is_supported($method);
201 0         0 $default_compression = $method;
202             }
203              
204             =item $level = compression_get_default_level()
205              
206             Return the default compression level used when compressing data. It's "9"
207             for "gzip" and "bzip2", "6" for "xz" and "lzma", unless
208             C has been used to change it.
209              
210             =item compression_set_default_level($level)
211              
212             Change the default compression level. Passing undef as the level will
213             reset it to the compressor specific default, otherwise errors out if the
214             level is not valid (see C).
215              
216             =cut
217              
218             sub compression_get_default_level {
219 174 100   174 1 614 if (defined $default_compression_level) {
220 10         65 return $default_compression_level;
221             } else {
222 164         439 return compression_get_property($default_compression, 'default_level');
223             }
224             }
225              
226             sub compression_set_default_level {
227 15     15 1 40 my $level = shift;
228 15 50 66     50 error(g_('%s is not a compression level'), $level)
229             if defined($level) and not compression_is_valid_level($level);
230 15         35 $default_compression_level = $level;
231             }
232              
233             =item compression_is_valid_level($level)
234              
235             Returns a boolean indicating whether $level is a valid compression level
236             (it must be either a number between 1 and 9 or "fast" or "best")
237              
238             =cut
239              
240             sub compression_is_valid_level {
241 164     164 1 290 my $level = shift;
242 164         1360 return $level =~ /^([1-9]|fast|best)$/;
243             }
244              
245             =back
246              
247             =head1 CHANGES
248              
249             =head2 Version 2.00 (dpkg 1.20.0)
250              
251             Hide variables: $default_compression, $default_compression_level
252             and $compression_re_file_ext.
253              
254             =head2 Version 1.02 (dpkg 1.17.2)
255              
256             New function: compression_get_file_extension_regex()
257              
258             Deprecated variables: $default_compression, $default_compression_level
259             and $compression_re_file_ext
260              
261             =head2 Version 1.01 (dpkg 1.16.1)
262              
263             Default compression level is not global any more, it is per compressor type.
264              
265             =head2 Version 1.00 (dpkg 1.15.6)
266              
267             Mark the module as public.
268              
269             =cut
270              
271             1;