#!/usr/bin/perl
# unpacked -- lintian collector/unpack script
#

# Copyright © 1998 Christian Schwarz and Richard Braakman
# Copyright © 2019 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 http://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::coll::unpacked;

no lib '.';

use strict;
use warnings;
use autodie;

use IO::Async::Loop;
use IO::Async::Process;
use Path::Tiny;

use lib "$ENV{'LINTIAN_ROOT'}/lib";

use Lintian::Util qw(sort_file_index gzip safe_qx);

# Read up to 40kB at the time.  This happens to be 4096 "tar records"
# (with a block-size of 512 and a block factor of 20, which appears to
# be the default).  When we do full reads and writes of READ_SIZE (the
# OS willing), the receiving end will never be with an incomplete
# record.
use constant READ_SIZE => 4096 * 1024 * 10;

use constant SPACE => q{ };
use constant EMPTY => q{};
use constant COLON => q{:};
use constant NEWLINE => qq{\n};

sub collect {
    my ($pkg, $type, $dir) = @_;

    my $unpackedpath = "$dir/unpacked/";
    path($unpackedpath)->remove_tree
      if -d $unpackedpath;

    for my $file (qw(index index.gz index-errors unpacked-errors)) {
        unlink("$dir/$file") if -e "$dir/$file";
    }

    # stop here if we are only asked to remove the files
    return
      if $type =~ m/^remove-/;

    if ($type eq 'source') {

        print "N: Using dpkg-source to unpack $pkg\n"
          if $ENV{'LINTIAN_DEBUG'};

        # Ignore STDOUT of the child process because older versions of
        # dpkg-source print things out even with -q.
        my $loop = IO::Async::Loop->new;
        my $future = $loop->new_future;
        my $dpkgerror;

        my $process = IO::Async::Process->new(
            command => [
                'dpkg-source', '-q',
                '--no-check', '-x',
                "$dir/dsc", "$dir/unpacked"
            ],
            stderr => { into => \$dpkgerror },
            on_finish => sub {
                my ($self, $exitcode) = @_;
                my $status = ($exitcode >> 8);

                if ($status) {
                    my $message = "Non-zero status $status from dpkg-source";
                    $message .= COLON . NEWLINE . $dpkgerror
                      if length $dpkgerror;
                    $future->fail($message);
                    return;
                }

                $future->done('Done with dpkg-deb');
                return;
            });

        $loop->add($process);

        # awaits, and dies with message on failure
        $future->get;

        path("$dir/unpacked-errors")->append($dpkgerror // EMPTY);

        # chdir for index_src
        chdir("$dir/unpacked");
        my $output = safe_qx(
            'find', '(',  '-type', 'l',
            # If symlink
            '-printf', '%M 0/0 %s %AY-%Am-%Ad %AH:%AM %p -> %l\0',
            '-true',             # elif dir [needs trailing slash]
            ')', '-o', '(',  '-type', 'd',
            '-printf', '%M 0/0 %s %AY-%Am-%Ad %AH:%AM %p/\0', '-true',
            # else (not dir and not symlink)
            ')', '-o', '-printf', '%M 0/0 %s %AY-%Am-%Ad %AH:%AM %p\0'
        );

        # Link targets can have newlines in them.  A lesson learned by
        # clasp (#765311) - We must also escape backslashes.  That would
        # be the \x5c values (used to avoid a mass of backslashes).
        $output =~ s/\x5c/\x5c\x5c/g;
        $output =~ s/\n/\\\n/g;

        my @unsorted = split(/\0/, $output);

        # sorts according to LC_ALL=C
        my @sorted
          = sort { (split(SPACE, $a))[5] cmp(split(SPACE, $b))[5] } @unsorted;

        my $uncompressed;
        $uncompressed .= $_ . NEWLINE for @sorted;
        gzip($uncompressed, "$dir/index.gz");

        # fix permissions
        safe_qx('chmod', '-R', 'u+rwX,o+rX,o-w', "$dir/unpacked");

        # remove error file if empty
        unlink("$dir/unpacked-errors") if -z "$dir/unpacked-errors";

    } else {

        # binary package
        mkdir("$dir/unpacked", 0777);

        my $loop = IO::Async::Loop->new;

        # get system tarball from deb
        my $deberror;
        my $dpkgdeb = $loop->new_future;
        my $debprocess = IO::Async::Process->new(
            command => ['dpkg-deb', '--fsys-tarfile', "$dir/deb"],
            stdout => { via => 'pipe_read' },
            stderr => { into => \$deberror },
            on_finish => sub {
                my ($self, $exitcode) = @_;
                my $status = ($exitcode >> 8);

                if ($status) {
                    my $message
                      = "Non-zero status $status from dpkg-deb for control";
                    $message .= COLON . NEWLINE . $deberror
                      if length $deberror;
                    $dpkgdeb->fail($message);
                    return;
                }

                $dpkgdeb->done('Done with dpkg-deb');
                return;
            });

        # extract the tarball's contents
        my $extracterror;
        my $extractor = $loop->new_future;
        my $extractprocess = IO::Async::Process->new(
            command => [
                'tar', '--no-same-owner', '--no-same-permissions',
                '-mxf','-', '-C', "$dir/unpacked"
            ],
            stdin => { via => 'pipe_write' },
            stderr => { into => \$extracterror },
            on_finish => sub {
                my ($self, $exitcode) = @_;
                my $status = ($exitcode >> 8);

                if ($status) {
                    my $message = "Non-zero status $status from extract tar";
                    $message .= COLON . NEWLINE . $extracterror
                      if length $extracterror;
                    $extractor->fail($message);
                    return;
                }

                $extractor->done('Done with extract tar');
                return;
            });

        # create index (named-owner)
        my $named;
        my $namederror;
        my $namedindexer = $loop->new_future;
        my $namedindexprocess = IO::Async::Process->new(
            command => ['tar', '--utc', '--full-time', '-stvf', '-'],
            stdin => { via => 'pipe_write' },
            stdout => { into => \$named },
            stderr => { into => \$namederror },
            on_finish => sub {
                my ($self, $exitcode) = @_;
                my $status = ($exitcode >> 8);

                if ($status) {
                    my $message = "Non-zero status $status from index tar";
                    $message .= COLON . NEWLINE . $namederror
                      if length $namederror;
                    $namedindexer->fail($message);
                    return;
                }

                $namedindexer->done('Done with named index tar');
                return;
            });

        # create index (numeric-owner)
        my $numeric;
        my $numericerror;
        my $numericindexer = $loop->new_future;
        my $numericindexprocess = IO::Async::Process->new(
            command =>
              ['tar', '--utc','--full-time', '--numeric-owner','-stvf','-'],
            stdin => { via => 'pipe_write' },
            stdout => { into => \$numeric },
            stderr => { into => \$numericerror },
            on_finish => sub {
                my ($self, $exitcode) = @_;
                my $status = ($exitcode >> 8);

                if ($status) {
                    my $message = "Non-zero status $status from index tar";
                    $message .= COLON . NEWLINE . $numericerror
                      if length $numericerror;
                    $numericindexer->fail($message);
                    return;
                }

                $numericindexer->done('Done with tar');
                return;
            });

        $extractprocess->stdin->configure(write_len => READ_SIZE,);
        $namedindexprocess->stdin->configure(write_len => READ_SIZE,);
        $numericindexprocess->stdin->configure(write_len => READ_SIZE,);

        $debprocess->stdout->configure(
            read_len => READ_SIZE,
            on_read => sub {
                my ($stream, $buffref, $eof) = @_;

                if (length $$buffref) {
                    $extractprocess->stdin->write($$buffref);
                    $namedindexprocess->stdin->write($$buffref);
                    $numericindexprocess->stdin->write($$buffref);

                    $$buffref = EMPTY;
                }

                if ($eof) {
                    $extractprocess->stdin->close_when_empty;
                    $namedindexprocess->stdin->close_when_empty;
                    $numericindexprocess->stdin->close_when_empty;
                }

                return 0;
            },
        );

        $loop->add($debprocess);
        $loop->add($extractprocess);
        $loop->add($namedindexprocess);
        $loop->add($numericindexprocess);

        my $composite = Future->needs_all($dpkgdeb, $extractor, $namedindexer,
            $numericindexer);

        # awaits, and dies on failure with message from failed constituent
        $composite->get;

        path("$dir/unpacked-errors")->append($deberror // EMPTY);
        path("$dir/unpacked-errors")->append($extracterror // EMPTY);
        path("$dir/index-errors")->append($namederror // EMPTY);

        # sorts according to LC_ALL=C
        $named = sort_file_index($named // EMPTY);
        gzip($named, "$dir/index.gz");

        # sorts according to LC_ALL=C
        $numeric = sort_file_index($numeric // EMPTY);
        gzip($numeric, "$dir/index-owner-id.gz");

        # remove error files if empty
        unlink("$dir/index-errors") if -z "$dir/index-errors";
        unlink("$dir/unpacked-errors") if -z "$dir/unpacked-errors";

        # fix permissions
        safe_qx('chmod', '-R', 'u+rwX,go-w', "$dir/unpacked");
    }

    return;
}

collect(@ARGV) unless caller;

1;

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 4
# End:
# vim: syntax=perl sw=4 sts=4 sr et
