#!/usr/bin/perl
#
# Copyright © 2012 Niels Thykier
# Copyright © 2019 Felix Lechner
#
# Based on coll/index which is: Copyright © 1998 Christian Schwarz
#
# 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::src_orig_index;

no lib '.';

use strict;
use warnings;
use autodie;

use Cwd();
use IO::Async::Loop;
use IO::Async::Process;
use Path::Tiny;

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

use Lintian::Collect::Dispatcher qw(create_info);
use Lintian::Processable::Source;
use Lintian::Util qw(internal_error sort_file_index gzip);

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

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

    my $info = create_info($pkg, $type, $dir);

    my $origpath = "$dir/src-orig-index.gz";
    unlink($origpath)
      if -f $origpath;

    # for native packages, just link to regular index
    if ($info->native) {
        link("$dir/index.gz", $origpath);
        return;
    }

    index_orig($pkg, $dir, $info);

    return;
}

# returns all (orig) tarballs.
sub gather_tarballs {
    my ($pkg, $dir, $info) = @_;
    my $file = Cwd::realpath("$dir/dsc");
    my $version;
    my @tarballs;
    my $base;
    my $baserev;

    internal_error(
        "Cannot resolve \"dsc\" link for $pkg or it does not point to a file.")
      unless $file and -e $file;

    # Use Lintian::Processable::Package to determine source and
    # version as it handles missing fields for us to some extent.

    my $proc = Lintian::Processable::Source->new;
    $proc->init($file);

    #  Version handling is based on Dpkg::Version::parseversion.
    $version = $proc->source_version;
    if ($version =~ /:/) {
        $version =~ s/^(?:\d+):(.+)/$1/
          or internal_error("bad version number \"$version\"");
    }

    $baserev = $proc->source . '_' . $version;
    $version =~ s/(.+)-(?:.*)$/$1/;
    $base = $proc->source . '_' . $version;

    for my $fs (split /\n/, $info->field('files', '')) {
        $fs =~ s/^\s*//;
        next if $fs eq '';
        my @t = split /\s+/o, $fs;
        next if $t[2] =~ m,/,;
        # Look for $pkg_$version.orig(-$comp)?.tar.$ext (non-native)
        #       or $pkg_$version.tar.$ext (native)
        #  - This deliberately does not look for the debian packaging
        #    even when this would be a tarball.
        if ($t[2]
            =~ /^(?:\Q$base\E\.orig(?:-(.*))?|\Q$baserev\E)\.tar\.(?:gz|bz2|lzma|xz)$/
        ) {
            push @tarballs, [$t[2], $1//''];
        }
    }
    internal_error('could not find the source tarball') unless @tarballs;

    return @tarballs;
}

# Creates an index of the orig tarballs the source package
sub index_orig {
    my ($pkg, $dir, $info) = @_;
    my @tarballs = gather_tarballs($pkg, $dir, $info);
    my @result;
    foreach my $tardata (@tarballs) {
        my ($tarball, $compname) = @$tardata;
        my @index;

        # Collect a list of the files in the source package.  tar
        # currently doesn't automatically recognize LZMA / XZ, so we
        # need to add the option where it's needed.  Change hard link
        # status (h) to regular files and remove a leading ./ prefix
        # on filenames while we're reading the tar output.  We
        # intentionally don't parallelize this job because we need to
        # use the output below.
        my @tar_options = ('--utc', '--full-time', '-tvf');
        if ($tarball =~ /\.(lzma|xz)\z/) {
            unshift @tar_options, "--$1";
        }
        my @tar = ('tar', @tar_options, "$dir/$tarball");

        my $loop = IO::Async::Loop->new;
        my $future = $loop->new_future;
        my $stdout;
        my $stderr;

        my $process = IO::Async::Process->new(
            command => [@tar],
            stdout => { into => \$stdout },
            stderr => { into => \$stderr },
            on_finish => sub {
                my ($self, $exitcode) = @_;
                my $status = ($exitcode >> 8);

                path("$dir/orig-index-errors")->append($stderr // EMPTY);

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

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

        $loop->add($process);

        $future->get;

        my @lines = split(/\n/, $stdout);
        for my $line (@lines) {
            $line =~ s/^h/-/;
            if ($line and $line !~ m,^(?:\S+\s+){5}\./$,) {
                push(@index, $line . NEWLINE);
            }
        }

        # We now need to see if all files in the tarball have a common
        # prefix.  If so, we're going to strip that prefix off each
        # file name.  We also remove lines that consist solely of the
        # prefix.
        my $prefix;
        for my $line (@index) {
            my ($filename) = ($line =~ /^(?:\S+\s+){5}(.*)/);
            $filename =~ s,^\./+,,o;
            my ($dirname) = ($filename =~ m,^([^/]+),);
            if (    defined $dirname
                and $dirname eq $filename
                and not $line =~ m/^d/o) {
                $prefix = '';
            } elsif (defined $dirname) {
                if (not defined $prefix) {
                    $prefix = $dirname;
                } elsif ($dirname ne $prefix) {
                    $prefix = '';
                }
            } else {
                $prefix = '';
            }
        }
        # Ensure $prefix is defined - this may appear to be redundant, but
        # no tarballs are present (happens if you wget rather than dget
        # the .dsc file >.>)
        $prefix //= '';

        # If there is a common prefix and it is $compname, then we use that
        # because that is where they will be extracted by unpacked.
        if ($prefix ne $compname) {
            # If there is a common prefix and it is not $compname
            # then strip the prefix and add $compname (if any)
            if ($prefix) {
                @index = map {
                    if (m,^((?:\S+\s+){5})(?:\./)?\Q$prefix\E(?:/+(.*+)?|\Z),){
                        my ($data, $file) = ($1, $2);
                        if ($file && $file !~ m,^(?:/++)?\Z,o){
                            $file = "$compname/$file" if $compname;
                            "$data$file\n";
                        } else {
                            ();
                        }
                    } else {
                        ();
                    }
                } @index;
            } elsif ($compname) {
                # Prefix with the compname (because that is where they will be
                # unpacked to.
                @index = map {
                    s{^((?:\S++\s++){5})(?:\./)?\Q$prefix\E(?:/+)?}
                    {$1$compname/}r
                } @index;
            }
        }
        push @result, @index;
    }

    # we have the file names, write sorted to the index
    my $unsorted = join(EMPTY, @result);

    # sorts according to LC_ALL=C
    my $sorted = sort_file_index($unsorted);
    gzip($sorted, "$dir/src-orig-index.gz");

    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
