scripts/Dpkg/Compression.pm

   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 =head1 NAME
  20
  21 Dpkg::Compression - simple database of available compression methods
  22
  23 =head1 DESCRIPTION
  24
  25 This modules provides a few public functions and a public regex to
  26 interact with the set of supported compression methods.
  27
  28 =cut
  29
  30 package Dpkg::Compression 2.01;
  31
  32 use strict;
  33 use warnings;
  34
  35 our @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 use Exporter qw(import);
  56 use Config;
  57 use List::Util qw(any);
  58
  59 use Dpkg::ErrorHandling;
  60 use Dpkg::Gettext;
  61
  62 my %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.
  99 if (any { $Config{osname} eq $_ } qw(linux gnu solaris)) {
 100     push @{$COMP{gzip}{comp_prog}}, '--rsyncable';
 101 }
 102
 103 my $default_compression = 'xz';
 104 my $default_compression_level = undef;
 105 my $default_compression_threads = 0;
 106
 107 my $regex = join '|', map { $_->{file_ext} } values %COMP;
 108 my $compression_re_file_ext = qr/(?:$regex)/;
 109
 110 =head1 FUNCTIONS
 111
 112 =over 4
 113
 114 =item @list = compression_get_list()
 115
 116 Returns a list of supported compression methods (sorted alphabetically).
 117
 118 =cut
 119
 120 sub compression_get_list {
 121     my @list = sort keys %COMP;
 122     return @list;
 123 }
 124
 125 =item compression_is_supported($comp)
 126
 127 Returns a boolean indicating whether the give compression method is
 128 known and supported.
 129
 130 =cut
 131
 132 sub compression_is_supported {
 133     my $comp = shift;
 134
 135     return exists $COMP{$comp};
 136 }
 137
 138 =item compression_get_property($comp, $property)
 139
 140 Returns the requested property of the compression method. Returns undef if
 141 either the property or the compression method doesn't exist. Valid
 142 properties 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
 145 the name of the decompression program.
 146
 147 This function is deprecated, please switch to one of the new specialized
 148 getters instead.
 149
 150 =cut
 151
 152 sub compression_get_property {
 153     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     return unless compression_is_supported($comp);
 159     return $COMP{$comp}{$property} if exists $COMP{$comp}{$property};
 160     return;
 161 }
 162
 163 =item compression_guess_from_filename($filename)
 164
 165 Returns the compression method that is likely used on the indicated
 166 filename based on its file extension.
 167
 168 =cut
 169
 170 sub compression_guess_from_filename {
 171     my $filename = shift;
 172     foreach my $comp (compression_get_list()) {
 173         my $ext = $COMP{$comp}{file_ext};
 174         if ($filename =~ /^(.*)\.\Q$ext\E$/) {
 175             return $comp;
 176         }
 177     }
 178     return;
 179 }
 180
 181 =item $regex = compression_get_file_extension_regex()
 182
 183 Returns a regex that matches a file extension of a file compressed with
 184 one of the supported compression methods.
 185
 186 =cut
 187
 188 sub compression_get_file_extension_regex {
 189     return $compression_re_file_ext;
 190 }
 191
 192 =item $ext = compression_get_file_extension($comp)
 193
 194 Return the file extension for the compressor $comp.
 195
 196 =cut
 197
 198 sub compression_get_file_extension {
 199     my $comp = shift;
 200
 201     error(g_('%s is not a supported compression'), $comp)
 202         unless compression_is_supported($comp);
 203
 204     return $COMP{$comp}{file_ext};
 205 }
 206
 207 =item $comp = compression_get_default()
 208
 209 Return the default compression method. It is "xz" unless
 210 C<compression_set_default> has been used to change it.
 211
 212 =cut
 213
 214 sub compression_get_default {
 215     return $default_compression;
 216 }
 217
 218 =item compression_set_default($comp)
 219
 220 Change the default compression method. Errors out if the
 221 given compression method is not supported.
 222
 223 =cut
 224
 225 sub compression_set_default {
 226     my $method = shift;
 227     error(g_('%s is not a supported compression'), $method)
 228         unless compression_is_supported($method);
 229     $default_compression = $method;
 230 }
 231
 232 =item $level = compression_get_default_level()
 233
 234 Return the global default compression level used when compressing data if
 235 it has been set, otherwise the default level for the default compressor.
 236
 237 It's "9" for "gzip" and "bzip2", "6" for "xz" and "lzma", unless
 238 C<compression_set_default_level> has been used to change it.
 239
 240 =cut
 241
 242 sub compression_get_default_level {
 243     if (defined $default_compression_level) {
 244         return $default_compression_level;
 245     } else {
 246         return $COMP{$default_compression}{default_level};
 247     }
 248 }
 249
 250 =item compression_set_default_level($level)
 251
 252 Change the global default compression level. Passing undef as the level will
 253 reset it to the global default compressor specific default, otherwise errors
 254 out if the level is not valid (see C<compression_is_valid_level>).
 255
 256 =cut
 257
 258 sub compression_set_default_level {
 259     my $level = shift;
 260     error(g_('%s is not a compression level'), $level)
 261         if defined($level) and not compression_is_valid_level($level);
 262     $default_compression_level = $level;
 263 }
 264
 265 =item $level = compression_get_level($comp)
 266
 267 Return the compression level used when compressing data with a specific
 268 compressor. The value returned is the specific compression level if it has
 269 been set, otherwise the global default compression level if it has been set,
 270 falling back to the specific default compression level.
 271
 272 =cut
 273
 274 sub compression_get_level {
 275     my $comp = shift;
 276
 277     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            $COMP{$comp}{default_level};
 283 }
 284
 285 =item compression_set_level($comp, $level)
 286
 287 Change the compression level for a specific compressor. Passing undef as
 288 the level will reset it to the specific default compressor level, otherwise
 289 errors out if the level is not valid (see C<compression_is_valid_level>).
 290
 291 =cut
 292
 293 sub compression_set_level {
 294     my ($comp, $level) = @_;
 295
 296     error(g_('%s is not a supported compression'), $comp)
 297         unless compression_is_supported($comp);
 298     error(g_('%s is not a compression level'), $level)
 299         if defined $level && ! compression_is_valid_level($level);
 300
 301     $COMP{$comp}{level} = $level;
 302 }
 303
 304 =item compression_is_valid_level($level)
 305
 306 Returns a boolean indicating whether $level is a valid compression level
 307 (it must be either a number between 1 and 9 or "fast" or "best")
 308
 309 =cut
 310
 311 sub compression_is_valid_level {
 312     my $level = shift;
 313     return $level =~ /^([1-9]|fast|best)$/;
 314 }
 315
 316 =item $threads = compression_get_threads()
 317
 318 Return the number of threads to use for compression and decompression.
 319
 320 =cut
 321
 322 sub compression_get_threads {
 323     return $default_compression_threads;
 324 }
 325
 326 =item compression_set_threads($threads)
 327
 328 Change the threads to use for compression and decompression. Passing C<undef>
 329 or B<0> requests to use automatic mode, based on the current CPU cores on
 330 the system.
 331
 332 =cut
 333
 334 sub compression_set_threads {
 335     my $threads = shift;
 336
 337     error(g_('compression threads %s is not a number'), $threads)
 338         if defined $threads && $threads !~ m/^\d+$/;
 339     $default_compression_threads = $threads;
 340 }
 341
 342 =item @exec = compression_get_cmdline_compress($comp)
 343
 344 Returns a list ready to be passed to C<exec>, its first element is the
 345 program name for compression and the following elements are parameters
 346 for the program.
 347
 348 When executed the program will act as a filter between its standard input
 349 and its standard output.
 350
 351 =cut
 352
 353 sub compression_get_cmdline_compress {
 354     my $comp = shift;
 355
 356     error(g_('%s is not a supported compression'), $comp)
 357         unless compression_is_supported($comp);
 358
 359     my @prog = @{$COMP{$comp}{comp_prog}};
 360     my $level = compression_get_level($comp);
 361     if ($level =~ m/^[1-9]$/) {
 362         push @prog, "-$level";
 363     } else {
 364         push @prog, "--$level";
 365     }
 366     my $threads = compression_get_threads();
 367     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         push @prog, qw(--quiet --no-warn);
 371
 372         # Do not let xz fallback to single-threaded mode, to avoid
 373         # non-reproducible output.
 374         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         push @prog, $threads == 1 ? '-T+1' : "-T$threads";
 381     }
 382     return @prog;
 383 }
 384
 385 =item @exec = compression_get_cmdline_decompress($comp)
 386
 387 Returns a list ready to be passed to C<exec>, its first element is the
 388 program name for decompression and the following elements are parameters
 389 for the program.
 390
 391 When executed the program will act as a filter between its standard input
 392 and its standard output.
 393
 394 =cut
 395
 396 sub compression_get_cmdline_decompress {
 397     my $comp = shift;
 398
 399     error(g_('%s is not a supported compression'), $comp)
 400         unless compression_is_supported($comp);
 401
 402     my @prog = @{$COMP{$comp}{decomp_prog}};
 403
 404     my $threads = compression_get_threads();
 405     if ($comp eq 'xz') {
 406         push @prog, "-T$threads";
 407     }
 408
 409     return @prog;
 410 }
 411
 412 =back
 413
 414 =head1 CHANGES
 415
 416 =head2 Version 2.01 (dpkg 1.21.14)
 417
 418 New functions: compression_get_file_extension(), compression_get_level(),
 419 compression_set_level(), compression_get_cmdline_compress(),
 420 compression_get_cmdline_decompress(), compression_get_threads() and
 421 compression_set_threads().
 422
 423 Deprecated functions: compression_get_property().
 424
 425 =head2 Version 2.00 (dpkg 1.20.0)
 426
 427 Hide variables: $default_compression, $default_compression_level
 428 and $compression_re_file_ext.
 429
 430 =head2 Version 1.02 (dpkg 1.17.2)
 431
 432 New function: compression_get_file_extension_regex()
 433
 434 Deprecated variables: $default_compression, $default_compression_level
 435 and $compression_re_file_ext
 436
 437 =head2 Version 1.01 (dpkg 1.16.1)
 438
 439 Default compression level is not global any more, it is per compressor type.
 440
 441 =head2 Version 1.00 (dpkg 1.15.6)
 442
 443 Mark the module as public.
 444
 445 =cut
 446
 447 1;