<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># Copyright В© 2010 RaphaГ«l Hertzog &lt;hertzog@debian.org&gt;
# Copyright В© 2010-2013 Guillem Jover &lt;guillem@debian.org&gt;
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see &lt;https://www.gnu.org/licenses/&gt;.

package Dpkg::Compression;

use strict;
use warnings;

our $VERSION = '1.02';
our @EXPORT = qw(
    $compression_re_file_ext
    compression_is_supported
    compression_get_list
    compression_get_property
    compression_guess_from_filename
    compression_get_file_extension_regex
    compression_get_default
    compression_set_default
    compression_get_default_level
    compression_set_default_level
    compression_is_valid_level
);

use Exporter qw(import);
use Config;

use Dpkg::ErrorHandling;
use Dpkg::Gettext;

=encoding utf8

=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

my $COMP = {
    gzip =&gt; {
	file_ext =&gt; 'gz',
	comp_prog =&gt; [ 'gzip', '--no-name' ],
	decomp_prog =&gt; [ 'gunzip' ],
	default_level =&gt; 9,
    },
    bzip2 =&gt; {
	file_ext =&gt; 'bz2',
	comp_prog =&gt; [ 'bzip2' ],
	decomp_prog =&gt; [ 'bunzip2' ],
	default_level =&gt; 9,
    },
    lzma =&gt; {
	file_ext =&gt; 'lzma',
	comp_prog =&gt; [ 'xz', '--format=lzma' ],
	decomp_prog =&gt; [ 'unxz', '--format=lzma' ],
	default_level =&gt; 6,
    },
    xz =&gt; {
	file_ext =&gt; 'xz',
	comp_prog =&gt; [ 'xz' ],
	decomp_prog =&gt; [ 'unxz' ],
	default_level =&gt; 6,
    },
};

#
# XXX: The gzip package in Debian at some point acquired a Debian-specific
# --rsyncable option via a vendor patch. Which is not present in most of the
# major distributions, dpkg downstream systems, nor gzip upstream, who have
# stated they will most probably not accept it because people should be using
# pigz instead.
#
# This option should have never been accepted in dpkg, ever. But removing it
# now would probably cause demands for tarring and feathering. In addition
# we cannot use the Dpkg::Vendor logic because that would cause circular
# module dependencies. The whole affair is pretty disgusting really.
#
# Check the perl Config to discern Debian and hopefully derivatives too.
#
if ($Config{cf_by} eq 'Debian Project') {
    push @{$COMP-&gt;{gzip}-&gt;{comp_prog}}, '--rsyncable';
}

# XXX: Backwards compatibility, stop exporting on VERSION 2.00.
## no critic (Variables::ProhibitPackageVars)
our $default_compression = 'xz';
our $default_compression_level = undef;

my $regex = join '|', map { $_-&gt;{file_ext} } values %$COMP;
our $compression_re_file_ext = qr/(?:$regex)/;
## use critic

=head1 FUNCTIONS

=over 4

=item @list = compression_get_list()

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

=cut

sub compression_get_list {
    my @list = sort keys %$COMP;
    return @list;
}

=item compression_is_supported($comp)

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

=cut

sub compression_is_supported {
    my $comp = shift;

    return exists $COMP-&gt;{$comp};
}

=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

sub compression_get_property {
    my ($comp, $property) = @_;
    return unless compression_is_supported($comp);
    return $COMP-&gt;{$comp}{$property} if exists $COMP-&gt;{$comp}{$property};
    return;
}

=item compression_guess_from_filename($filename)

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

=cut

sub compression_guess_from_filename {
    my $filename = shift;
    foreach my $comp (compression_get_list()) {
	my $ext = compression_get_property($comp, 'file_ext');
        if ($filename =~ /^(.*)\.\Q$ext\E$/) {
	    return $comp;
        }
    }
    return;
}

=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

sub compression_get_file_extension_regex {
    return $compression_re_file_ext;
}

=item $comp = compression_get_default()

Return the default compression method. It is "xz" unless
C&lt;compression_set_default&gt; 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

sub compression_get_default {
    return $default_compression;
}

sub compression_set_default {
    my $method = shift;
    error(g_('%s is not a supported compression'), $method)
            unless compression_is_supported($method);
    $default_compression = $method;
}

=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&lt;compression_set_default_level&gt; 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&lt;compression_is_valid_level&gt;).

=cut

sub compression_get_default_level {
    if (defined $default_compression_level) {
        return $default_compression_level;
    } else {
        return compression_get_property($default_compression, 'default_level');
    }
}

sub compression_set_default_level {
    my $level = shift;
    error(g_('%s is not a compression level'), $level)
        if defined($level) and not compression_is_valid_level($level);
    $default_compression_level = $level;
}

=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

sub compression_is_valid_level {
    my $level = shift;
    return $level =~ /^([1-9]|fast|best)$/;
}

=back

=head1 CHANGES

=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

1;
</pre></body></html>