diff options
Diffstat (limited to '')
| -rw-r--r-- | scripts/Dpkg/Compression.pm | 448 | ||||
| -rw-r--r-- | scripts/Dpkg/Compression/FileHandle.pm | 473 | ||||
| -rw-r--r-- | scripts/Dpkg/Compression/Process.pm | 208 |
3 files changed, 1129 insertions, 0 deletions
diff --git a/scripts/Dpkg/Compression.pm b/scripts/Dpkg/Compression.pm new file mode 100644 index 0000000..189be8b --- /dev/null +++ b/scripts/Dpkg/Compression.pm @@ -0,0 +1,448 @@ +# Copyright © 2007-2022 Guillem Jover <guillem@debian.org> +# Copyright © 2010 Raphaël Hertzog <hertzog@debian.org> +# +# 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 <https://www.gnu.org/licenses/>. + +package Dpkg::Compression; + +use strict; +use warnings; + +our $VERSION = '2.01'; +our @EXPORT = qw( + compression_is_supported + compression_get_list + compression_get_property + compression_guess_from_filename + compression_get_file_extension_regex + compression_get_file_extension + compression_get_default + compression_set_default + compression_get_default_level + compression_set_default_level + compression_get_level + compression_set_level + compression_is_valid_level + compression_get_threads + compression_set_threads + compression_get_cmdline_compress + compression_get_cmdline_decompress +); + +use Exporter qw(import); +use Config; +use List::Util qw(any); + +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 => { + file_ext => 'gz', + comp_prog => [ 'gzip', '-n' ], + decomp_prog => [ 'gunzip' ], + default_level => 9, + }, + bzip2 => { + file_ext => 'bz2', + comp_prog => [ 'bzip2' ], + decomp_prog => [ 'bunzip2' ], + default_level => 9, + }, + lzma => { + file_ext => 'lzma', + comp_prog => [ 'xz', '--format=lzma' ], + decomp_prog => [ 'unxz', '--format=lzma' ], + default_level => 6, + }, + xz => { + file_ext => 'xz', + comp_prog => [ 'xz' ], + decomp_prog => [ 'unxz' ], + default_level => 6, + }, +); + +# The gzip --rsyncable option is not universally supported, so we need to +# conditionally use it. Ideally we would invoke 'gzip --help' and check +# whether the option is supported, but that would imply forking and executing +# that process for any module that ends up loading this one, which is not +# acceptable performance-wise. Instead we will approximate it by osname, which +# is not ideal, but better than nothing. +# +# Requires GNU gzip >= 1.7 for the --rsyncable option. On AIX GNU gzip is +# too old. On the BSDs they use their own implementation based on zlib, +# which does not currently support the --rsyncable option. +if (any { $Config{osname} eq $_ } qw(linux gnu solaris)) { + push @{$COMP{gzip}{comp_prog}}, '--rsyncable'; +} + +my $default_compression = 'xz'; +my $default_compression_level = undef; +my $default_compression_threads = 0; + +my $regex = join '|', map { $_->{file_ext} } values %COMP; +my $compression_re_file_ext = qr/(?:$regex)/; + +=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{$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. + +This function is deprecated, please switch to one of the new specialized +getters instead. + +=cut + +sub compression_get_property { + my ($comp, $property) = @_; + + #warnings::warnif('deprecated', + # 'Dpkg::Compression::compression_get_property() is deprecated, ' . + # 'use one of the specialized getters instead'); + return unless compression_is_supported($comp); + return $COMP{$comp}{$property} if exists $COMP{$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 = $COMP{$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 $ext = compression_get_file_extension($comp) + +Return the file extension for the compressor $comp. + +=cut + +sub compression_get_file_extension { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + return $COMP{$comp}{file_ext}; +} + +=item $comp = compression_get_default() + +Return the default compression method. It is "xz" unless +C<compression_set_default> has been used to change it. + +=cut + +sub compression_get_default { + return $default_compression; +} + +=item compression_set_default($comp) + +Change the default compression method. Errors out if the +given compression method is not supported. + +=cut + +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 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 +C<compression_set_default_level> has been used to change it. + +=cut + +sub compression_get_default_level { + if (defined $default_compression_level) { + return $default_compression_level; + } else { + return $COMP{$default_compression}{default_level}; + } +} + +=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 C<compression_is_valid_level>). + +=cut + +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 $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 + +sub compression_get_level { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + return $COMP{$comp}{level} // + $default_compression_level // + $COMP{$comp}{default_level}; +} + +=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 C<compression_is_valid_level>). + +=cut + +sub compression_set_level { + my ($comp, $level) = @_; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + error(g_('%s is not a compression level'), $level) + if defined $level && ! compression_is_valid_level($level); + + $COMP{$comp}{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)$/; +} + +=item $threads = compression_get_threads() + +Return the number of threads to use for compression and decompression. + +=cut + +sub compression_get_threads { + return $default_compression_threads; +} + +=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 + +sub compression_set_threads { + my $threads = shift; + + error(g_('compression threads %s is not a number'), $threads) + if defined $threads && $threads !~ m/^\d+$/; + $default_compression_threads = $threads; +} + +=item @exec = compression_get_cmdline_compress($comp) + +Returns a list ready to be passed to C<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 + +sub compression_get_cmdline_compress { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + my @prog = @{$COMP{$comp}{comp_prog}}; + my $level = compression_get_level($comp); + if ($level =~ m/^[1-9]$/) { + push @prog, "-$level"; + } else { + push @prog, "--$level"; + } + my $threads = compression_get_threads(); + if ($comp eq 'xz') { + # Do not generate warnings when adjusting memory usage, nor + # exit with non-zero due to those not emitted warnings. + push @prog, qw(--quiet --no-warn); + + # Do not let xz fallback to single-threaded mode, to avoid + # non-reproducible output. + push @prog, '--no-adjust'; + + # The xz -T1 option selects a single-threaded mode which generates + # different output than in multi-threaded mode. To avoid the + # non-reproducible output we pass -T+1 (supported with xz >= 5.4.0) + # to request multi-threaded mode with a single thread. + push @prog, $threads == 1 ? '-T+1' : "-T$threads"; + } + return @prog; +} + +=item @exec = compression_get_cmdline_decompress($comp) + +Returns a list ready to be passed to C<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 + +sub compression_get_cmdline_decompress { + my $comp = shift; + + error(g_('%s is not a supported compression'), $comp) + unless compression_is_supported($comp); + + my @prog = @{$COMP{$comp}{decomp_prog}}; + + my $threads = compression_get_threads(); + if ($comp eq 'xz') { + push @prog, "-T$threads"; + } + + return @prog; +} + +=back + +=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 + +1; diff --git a/scripts/Dpkg/Compression/FileHandle.pm b/scripts/Dpkg/Compression/FileHandle.pm new file mode 100644 index 0000000..5b3fd1c --- /dev/null +++ b/scripts/Dpkg/Compression/FileHandle.pm @@ -0,0 +1,473 @@ +# Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2012-2014 Guillem Jover <guillem@debian.org> +# +# 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 <https://www.gnu.org/licenses/>. + +package Dpkg::Compression::FileHandle; + +use strict; +use warnings; + +our $VERSION = '1.01'; + +use Carp; + +use Dpkg::Compression; +use Dpkg::Compression::Process; +use Dpkg::Gettext; +use Dpkg::ErrorHandling; + +use parent qw(IO::File Tie::Handle); + +# Useful reference to understand some kludges required to +# have the class behave like a filehandle +# http://blog.woobling.org/2009/10/are-filehandles-objects.html + +=encoding utf8 + +=head1 NAME + +Dpkg::Compression::FileHandle - class dealing transparently with file compression + +=head1 SYNOPSIS + + use Dpkg::Compression::FileHandle; + + my ($fh, @lines); + + $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); + print $fh "Something\n"; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + open($fh, '>', 'sample.bz2'); + print $fh "Something\n"; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + $fh->open('sample.xz', 'w'); + $fh->print("Something\n"); + $fh->close(); + + $fh = Dpkg::Compression::FileHandle->new(filename => 'sample.gz'); + @lines = <$fh>; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + open($fh, '<', 'sample.bz2'); + @lines = <$fh>; + close $fh; + + $fh = Dpkg::Compression::FileHandle->new(); + $fh->open('sample.xz', 'r'); + @lines = $fh->getlines(); + $fh->close(); + +=head1 DESCRIPTION + +Dpkg::Compression::FileHandle is a class that can be used +like any filehandle and that deals transparently with compressed +files. By default, the compression scheme is guessed from the filename +but you can override this behaviour with the method C<set_compression>. + +If you don't open the file explicitly, it will be auto-opened on the +first read or write operation based on the filename set at creation time +(or later with the C<set_filename> method). + +Once a file has been opened, the filehandle must be closed before being +able to open another file. + +=head1 STANDARD FUNCTIONS + +The standard functions acting on filehandles should accept a +Dpkg::Compression::FileHandle object transparently including +C<open> (only when using the variant with 3 parameters), C<close>, +C<binmode>, C<eof>, C<fileno>, C<getc>, C<print>, C<printf>, C<read>, +C<sysread>, C<say>, C<write>, C<syswrite>, C<seek>, C<sysseek>, C<tell>. + +Note however that C<seek> and C<sysseek> will only work on uncompressed +files as compressed files are really pipes to the compressor programs +and you can't seek on a pipe. + +=head1 FileHandle METHODS + +The class inherits from IO::File so all methods that work on this +class should work for Dpkg::Compression::FileHandle too. There +may be exceptions though. + +=head1 PUBLIC METHODS + +=over 4 + +=item $fh = Dpkg::Compression::FileHandle->new(%opts) + +Creates a new filehandle supporting on-the-fly compression/decompression. +Supported options are "filename", "compression", "compression_level" (see +respective set_* functions) and "add_comp_ext". If "add_comp_ext" +evaluates to true, then the extension corresponding to the selected +compression scheme is automatically added to the recorded filename. It's +obviously incompatible with automatic detection of the compression method. + +=cut + +# Class methods +sub new { + my ($this, %args) = @_; + my $class = ref($this) || $this; + my $self = IO::File->new(); + # Tying is required to overload the open functions and to auto-open + # the file on first read/write operation + tie *$self, $class, $self; ## no critic (Miscellanea::ProhibitTies) + bless $self, $class; + # Initializations + *$self->{compression} = 'auto'; + *$self->{compressor} = Dpkg::Compression::Process->new(); + *$self->{add_comp_ext} = $args{add_compression_extension} || + $args{add_comp_ext} || 0; + *$self->{allow_sigpipe} = 0; + if (exists $args{filename}) { + $self->set_filename($args{filename}); + } + if (exists $args{compression}) { + $self->set_compression($args{compression}); + } + if (exists $args{compression_level}) { + $self->set_compression_level($args{compression_level}); + } + return $self; +} + +=item $fh->ensure_open($mode, %opts) + +Ensure the file is opened in the requested mode ("r" for read and "w" for +write). The options are passed down to the compressor's spawn() call, if one +is used. Opens the file with the recorded filename if needed. If the file +is already open but not in the requested mode, then it errors out. + +=cut + +sub ensure_open { + my ($self, $mode, %opts) = @_; + if (exists *$self->{mode}) { + return if *$self->{mode} eq $mode; + croak "ensure_open requested incompatible mode: $mode"; + } else { + # Sanitize options. + delete $opts{from_pipe}; + delete $opts{from_file}; + delete $opts{to_pipe}; + delete $opts{to_file}; + + if ($mode eq 'w') { + $self->_open_for_write(%opts); + } elsif ($mode eq 'r') { + $self->_open_for_read(%opts); + } else { + croak "invalid mode in ensure_open: $mode"; + } + } +} + +## +## METHODS FOR TIED HANDLE +## +sub TIEHANDLE { + my ($class, $self) = @_; + return $self; +} + +sub WRITE { + my ($self, $scalar, $length, $offset) = @_; + $self->ensure_open('w'); + return *$self->{file}->write($scalar, $length, $offset); +} + +sub READ { + my ($self, $scalar, $length, $offset) = @_; + $self->ensure_open('r'); + return *$self->{file}->read($scalar, $length, $offset); +} + +sub READLINE { + my ($self) = shift; + $self->ensure_open('r'); + return *$self->{file}->getlines() if wantarray; + return *$self->{file}->getline(); +} + +sub OPEN { + my ($self) = shift; + if (scalar(@_) == 2) { + my ($mode, $filename) = @_; + $self->set_filename($filename); + if ($mode eq '>') { + $self->_open_for_write(); + } elsif ($mode eq '<') { + $self->_open_for_read(); + } else { + croak 'Dpkg::Compression::FileHandle does not support ' . + "open() mode $mode"; + } + } else { + croak 'Dpkg::Compression::FileHandle only supports open() ' . + 'with 3 parameters'; + } + return 1; # Always works (otherwise errors out) +} + +sub CLOSE { + my ($self) = shift; + my $ret = 1; + if (defined *$self->{file}) { + $ret = *$self->{file}->close(@_) if *$self->{file}->opened(); + } else { + $ret = 0; + } + $self->_cleanup(); + return $ret; +} + +sub FILENO { + my ($self) = shift; + return *$self->{file}->fileno(@_) if defined *$self->{file}; + return; +} + +sub EOF { + # Since perl 5.12, an integer parameter is passed describing how the + # function got called, just ignore it. + my ($self, $param) = (shift, shift); + return *$self->{file}->eof(@_) if defined *$self->{file}; + return 1; +} + +sub SEEK { + my ($self) = shift; + return *$self->{file}->seek(@_) if defined *$self->{file}; + return 0; +} + +sub TELL { + my ($self) = shift; + return *$self->{file}->tell(@_) if defined *$self->{file}; + return -1; +} + +sub BINMODE { + my ($self) = shift; + return *$self->{file}->binmode(@_) if defined *$self->{file}; + return; +} + +## +## NORMAL METHODS +## + +=item $fh->set_compression($comp) + +Defines the compression method used. $comp should one of the methods supported by +B<Dpkg::Compression> or "none" or "auto". "none" indicates that the file is +uncompressed and "auto" indicates that the method must be guessed based +on the filename extension used. + +=cut + +sub set_compression { + my ($self, $method) = @_; + if ($method ne 'none' and $method ne 'auto') { + *$self->{compressor}->set_compression($method); + } + *$self->{compression} = $method; +} + +=item $fh->set_compression_level($level) + +Indicate the desired compression level. It should be a value accepted +by the function C<compression_is_valid_level> of B<Dpkg::Compression>. + +=cut + +sub set_compression_level { + my ($self, $level) = @_; + *$self->{compressor}->set_compression_level($level); +} + +=item $fh->set_filename($name, [$add_comp_ext]) + +Use $name as filename when the file must be opened/created. If +$add_comp_ext is passed, it indicates whether the default extension +of the compression method must be automatically added to the filename +(or not). + +=cut + +sub set_filename { + my ($self, $filename, $add_comp_ext) = @_; + *$self->{filename} = $filename; + # Automatically add compression extension to filename + if (defined($add_comp_ext)) { + *$self->{add_comp_ext} = $add_comp_ext; + } + my $comp_ext_regex = compression_get_file_extension_regex(); + if (*$self->{add_comp_ext} and $filename =~ /\.$comp_ext_regex$/) { + warning('filename %s already has an extension of a compressed file ' . + 'and add_comp_ext is active', $filename); + } +} + +=item $file = $fh->get_filename() + +Returns the filename that would be used when the filehandle must +be opened (both in read and write mode). This function errors out +if "add_comp_ext" is enabled while the compression method is set +to "auto". The returned filename includes the extension of the compression +method if "add_comp_ext" is enabled. + +=cut + +sub get_filename { + my $self = shift; + my $comp = *$self->{compression}; + if (*$self->{add_comp_ext}) { + if ($comp eq 'auto') { + croak 'automatic detection of compression is ' . + 'incompatible with add_comp_ext'; + } elsif ($comp eq 'none') { + return *$self->{filename}; + } else { + return *$self->{filename} . '.' . + compression_get_file_extension($comp); + } + } else { + return *$self->{filename}; + } +} + +=item $ret = $fh->use_compression() + +Returns "0" if no compression is used and the compression method used +otherwise. If the compression is set to "auto", the value returned +depends on the extension of the filename obtained with the B<get_filename> +method. + +=cut + +sub use_compression { + my $self = shift; + my $comp = *$self->{compression}; + if ($comp eq 'none') { + return 0; + } elsif ($comp eq 'auto') { + $comp = compression_guess_from_filename($self->get_filename()); + *$self->{compressor}->set_compression($comp) if $comp; + } + return $comp; +} + +=item $real_fh = $fh->get_filehandle() + +Returns the real underlying filehandle. Useful if you want to pass it +along in a derived class. + +=cut + +sub get_filehandle { + my $self = shift; + return *$self->{file} if exists *$self->{file}; +} + +## INTERNAL METHODS + +sub _open_for_write { + my ($self, %opts) = @_; + my $filehandle; + + croak 'cannot reopen an already opened compressed file' + if exists *$self->{mode}; + + if ($self->use_compression()) { + *$self->{compressor}->compress(from_pipe => \$filehandle, + to_file => $self->get_filename(), %opts); + } else { + CORE::open($filehandle, '>', $self->get_filename) + or syserr(g_('cannot write %s'), $self->get_filename()); + } + *$self->{mode} = 'w'; + *$self->{file} = $filehandle; +} + +sub _open_for_read { + my ($self, %opts) = @_; + my $filehandle; + + croak 'cannot reopen an already opened compressed file' + if exists *$self->{mode}; + + if ($self->use_compression()) { + *$self->{compressor}->uncompress(to_pipe => \$filehandle, + from_file => $self->get_filename(), %opts); + *$self->{allow_sigpipe} = 1; + } else { + CORE::open($filehandle, '<', $self->get_filename) + or syserr(g_('cannot read %s'), $self->get_filename()); + } + *$self->{mode} = 'r'; + *$self->{file} = $filehandle; +} + +sub _cleanup { + my $self = shift; + my $cmdline = *$self->{compressor}{cmdline} // ''; + *$self->{compressor}->wait_end_process(nocheck => *$self->{allow_sigpipe}); + if (*$self->{allow_sigpipe}) { + require POSIX; + unless (($? == 0) || (POSIX::WIFSIGNALED($?) && + (POSIX::WTERMSIG($?) == POSIX::SIGPIPE()))) { + subprocerr($cmdline); + } + *$self->{allow_sigpipe} = 0; + } + delete *$self->{mode}; + delete *$self->{file}; +} + +=back + +=head1 DERIVED CLASSES + +If you want to create a class that inherits from +Dpkg::Compression::FileHandle you must be aware that +the object is a reference to a GLOB that is returned by Symbol::gensym() +and as such it's not a HASH. + +You can store internal data in a hash but you have to use +C<*$self->{...}> to access the associated hash like in the example below: + + sub set_option { + my ($self, $value) = @_; + *$self->{option} = $value; + } + +=head1 CHANGES + +=head2 Version 1.01 (dpkg 1.17.11) + +New argument: $fh->ensure_open() accepts an %opts argument. + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut +1; diff --git a/scripts/Dpkg/Compression/Process.pm b/scripts/Dpkg/Compression/Process.pm new file mode 100644 index 0000000..3f08d48 --- /dev/null +++ b/scripts/Dpkg/Compression/Process.pm @@ -0,0 +1,208 @@ +# Copyright © 2008-2010 Raphaël Hertzog <hertzog@debian.org> +# Copyright © 2008-2022 Guillem Jover <guillem@debian.org> +# +# 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 <https://www.gnu.org/licenses/>. + +package Dpkg::Compression::Process; + +use strict; +use warnings; + +our $VERSION = '1.00'; + +use Carp; + +use Dpkg::Compression; +use Dpkg::ErrorHandling; +use Dpkg::Gettext; +use Dpkg::IPC; + +=encoding utf8 + +=head1 NAME + +Dpkg::Compression::Process - run compression/decompression processes + +=head1 DESCRIPTION + +This module provides an object oriented interface to run and manage +compression/decompression processes. + +=head1 METHODS + +=over 4 + +=item $proc = Dpkg::Compression::Process->new(%opts) + +Create a new instance of the object. Supported options are "compression" +and "compression_level" (see corresponding set_* functions). + +=cut + +sub new { + my ($this, %args) = @_; + my $class = ref($this) || $this; + my $self = {}; + bless $self, $class; + $self->set_compression($args{compression} || compression_get_default()); + $self->set_compression_level($args{compression_level} || + compression_get_default_level()); + return $self; +} + +=item $proc->set_compression($comp) + +Select the compression method to use. It errors out if the method is not +supported according to C<compression_is_supported> (of +B<Dpkg::Compression>). + +=cut + +sub set_compression { + my ($self, $method) = @_; + error(g_('%s is not a supported compression method'), $method) + unless compression_is_supported($method); + $self->{compression} = $method; +} + +=item $proc->set_compression_level($level) + +Select the compression level to use. It errors out if the level is not +valid according to C<compression_is_valid_level> (of +B<Dpkg::Compression>). + +=cut + +sub set_compression_level { + my ($self, $level) = @_; + + compression_set_level($self->{compression}, $level); +} + +=item @exec = $proc->get_compress_cmdline() + +=item @exec = $proc->get_uncompress_cmdline() + +Returns a list ready to be passed to C<exec>, its first element is the +program name (either for compression or decompression) and the following +elements are parameters for the program. + +When executed the program acts as a filter between its standard input +and its standard output. + +=cut + +sub get_compress_cmdline { + my $self = shift; + + return compression_get_cmdline_compress($self->{compression}); +} + +sub get_uncompress_cmdline { + my $self = shift; + + return compression_get_cmdline_decompress($self->{compression}); +} + +sub _check_opts { + my ($self, %opts) = @_; + # Check for proper cleaning before new start + error(g_('Dpkg::Compression::Process can only start one subprocess at a time')) + if $self->{pid}; + # Check options + my $to = my $from = 0; + foreach my $thing (qw(file handle string pipe)) { + $to++ if $opts{"to_$thing"}; + $from++ if $opts{"from_$thing"}; + } + croak 'exactly one to_* parameter is needed' if $to != 1; + croak 'exactly one from_* parameter is needed' if $from != 1; + return %opts; +} + +=item $proc->compress(%opts) + +Starts a compressor program. You must indicate where it will read its +uncompressed data from and where it will write its compressed data to. +This is accomplished by passing one parameter C<to_*> and one parameter +C<from_*> as accepted by B<Dpkg::IPC::spawn>. + +You must call C<wait_end_process> after having called this method to +properly close the sub-process (and verify that it exited without error). + +=cut + +sub compress { + my ($self, %opts) = @_; + + $self->_check_opts(%opts); + my @prog = $self->get_compress_cmdline(); + $opts{exec} = \@prog; + $self->{cmdline} = "@prog"; + $self->{pid} = spawn(%opts); + delete $self->{pid} if $opts{to_string}; # wait_child already done +} + +=item $proc->uncompress(%opts) + +Starts a decompressor program. You must indicate where it will read its +compressed data from and where it will write its uncompressed data to. +This is accomplished by passing one parameter C<to_*> and one parameter +C<from_*> as accepted by B<Dpkg::IPC::spawn>. + +You must call C<wait_end_process> after having called this method to +properly close the sub-process (and verify that it exited without error). + +=cut + +sub uncompress { + my ($self, %opts) = @_; + + $self->_check_opts(%opts); + my @prog = $self->get_uncompress_cmdline(); + $opts{exec} = \@prog; + $self->{cmdline} = "@prog"; + $self->{pid} = spawn(%opts); + delete $self->{pid} if $opts{to_string}; # wait_child already done +} + +=item $proc->wait_end_process(%opts) + +Call B<Dpkg::IPC::wait_child> to wait until the sub-process has exited +and verify its return code. Any given option will be forwarded to +the C<wait_child> function. Most notably you can use the "nocheck" option +to verify the return code yourself instead of letting C<wait_child> do +it for you. + +=cut + +sub wait_end_process { + my ($self, %opts) = @_; + $opts{cmdline} //= $self->{cmdline}; + wait_child($self->{pid}, %opts) if $self->{pid}; + delete $self->{pid}; + delete $self->{cmdline}; +} + +=back + +=head1 CHANGES + +=head2 Version 1.00 (dpkg 1.15.6) + +Mark the module as public. + +=cut + +1; |