diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Lintian/IO/Select.pm | 259 |
1 files changed, 259 insertions, 0 deletions
diff --git a/lib/Lintian/IO/Select.pm b/lib/Lintian/IO/Select.pm new file mode 100644 index 0000000..fec6a1e --- /dev/null +++ b/lib/Lintian/IO/Select.pm @@ -0,0 +1,259 @@ +# Hey emacs! This is a -*- Perl -*- script! +# +# Lintian::IO::Select -- Perl utility functions for lintian +# +# Copyright (C) 2020 Felix Lechner +# +# 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, you can find it on the World Wide +# Web at https://www.gnu.org/copyleft/gpl.html, or write to the Free +# Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, +# MA 02110-1301, USA. + +package Lintian::IO::Select; + +use v5.20; +use warnings; +use utf8; + +use Exporter qw(import); + +our @EXPORT_OK; + +BEGIN { + + @EXPORT_OK = qw( + unpack_and_index_piped_tar + ); +} + +use Const::Fast; +use IPC::Open3; +use IO::Select; +use Symbol; +use Syntax::Keyword::Try; +use Unicode::UTF8 qw(encode_utf8); + +# read up to 40kB at a time. this happens to be 4096 "tar records" +# (with a block-size of 512 and a block factor of 20, which appear to +# be the defaults). when we do full reads and writes of READ_SIZE (the +# OS willing), the receiving end will never be with an incomplete +# record. +const my $TAR_RECORD_SIZE => 20 * 512; + +# using 4096 * $TAR_RECORD_SIZE tripped up older kernels < 5.7 +const my $READ_CHUNK => 4 * 1024; + +const my $EMPTY => q{}; + +=head1 NAME + +Lintian::IO::Select - process functions based on IO::Select + +=head1 SYNOPSIS + + use Lintian::IO::Select; + +=head1 DESCRIPTION + +This module contains process functions based on IO::Select. + +=head1 FUNCTIONS + +=over 4 + +=item unpack_and_index_piped_tar + +=cut + +sub unpack_and_index_piped_tar { + my ($command, $basedir) = @_; + + my @pids; + + my $select = IO::Select->new; + + my $produce_stdin; + my $produce_stdout; + my $produce_stderr = gensym; + + my @produce_command = @{$command}; + + my $produce_pid; + try { + $produce_pid = open3( + $produce_stdin, $produce_stdout, + $produce_stderr, @produce_command + ); + } catch { + die map { encode_utf8($_) } $@; + } + + close $produce_stdin; + + push(@pids, $produce_pid); + + $select->add($produce_stdout, $produce_stderr); + + my $extract_stdin; + my $extract_stdout; + my $extract_stderr = gensym; + + my @extract_command = ( + qw(tar --no-same-owner --no-same-permissions --touch --extract --file - -C), + $basedir + ); + + my $extract_pid; + try { + $extract_pid = open3( + $extract_stdin, $extract_stdout, + $extract_stderr, @extract_command + ); + } catch { + die map { encode_utf8($_) } $@; + } + + push(@pids, $extract_pid); + + $select->add($extract_stdout, $extract_stderr); + + my @index_options + = qw(--list --verbose --utc --full-time --quoting-style=c --file -); + + my $named_stdin; + my $named_stdout; + my $named_stderr = gensym; + + my @named_command = ('tar', @index_options); + + my $named_pid; + try { + $named_pid + = open3($named_stdin, $named_stdout, $named_stderr, @named_command); + } catch { + die map { encode_utf8($_) } $@; + } + + push(@pids, $named_pid); + + $select->add($named_stdout, $named_stderr); + + my $numeric_stdin; + my $numeric_stdout; + my $numeric_stderr = gensym; + + my @numeric_command = ('tar', '--numeric-owner', @index_options); + + my $numeric_pid; + try { + $numeric_pid = open3( + $numeric_stdin, $numeric_stdout, + $numeric_stderr, @numeric_command + ); + } catch { + die map { encode_utf8($_) } $@; + } + + push(@pids, $numeric_pid); + + $select->add($numeric_stdout, $numeric_stderr); + + my $named = $EMPTY; + my $numeric = $EMPTY; + + my $produce_errors = $EMPTY; + my $extract_errors = $EMPTY; + my $named_errors = $EMPTY; + + while (my @ready = $select->can_read) { + + for my $handle (@ready) { + + my $buffer; + my $length = sysread($handle, $buffer, $READ_CHUNK); + + die encode_utf8("Error from child: $!\n") + unless defined $length; + + if ($length == 0){ + if ($handle == $produce_stdout) { + close $extract_stdin; + close $named_stdin; + close $numeric_stdin; + } + $select->remove($handle); + next; + } + + if ($handle == $produce_stdout) { + print {$extract_stdin} $buffer; + print {$named_stdin} $buffer; + print {$numeric_stdin} $buffer; + + } elsif ($handle == $named_stdout) { + $named .= $buffer; + + } elsif ($handle == $numeric_stdout) { + $numeric .= $buffer; + + } elsif ($handle == $produce_stderr) { + $produce_errors .= $buffer; + + } elsif ($handle == $extract_stderr) { + $extract_errors .= $buffer; + + } elsif ($handle == $named_stderr) { + $named_errors .= $buffer; + + # } else { + # die encode_utf8("Shouldn't be here\n"); + } + } + } + + close $produce_stdout; + close $produce_stderr; + + close $extract_stdout; + close $extract_stderr; + + close $named_stdout; + close $named_stderr; + + close $numeric_stdout; + close $numeric_stderr; + + waitpid($_, 0) for @pids; + + my $tar_errors = ($produce_errors // $EMPTY) . ($extract_errors // $EMPTY); + my $index_errors = $named_errors; + + return ($named, $numeric, $tar_errors, $index_errors); +} + +=back + +=head1 SEE ALSO + +lintian(1) + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: +# vim: syntax=perl sw=4 sts=4 sr et |