#!/usr/bin/perl

# git-deborig -- try to produce Debian orig.tar using git-archive(1)

# Copyright (C) 2016-2019  Sean Whitton <spwhitton@spwhitton.name>
#
# 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 3 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 <http://www.gnu.org/licenses/>.

use strict;
use warnings;

use Getopt::Long;
use Git::Wrapper;
use Dpkg::Changelog::Parse;
use Dpkg::IPC;
use Dpkg::Version;
use List::Compare;
use String::ShellQuote;
use Try::Tiny;

my $git = Git::Wrapper->new(".");

# Sanity check #1
try {
    $git->rev_parse({ git_dir => 1 });
} catch {
    die "pwd doesn't look like a git repository ..\n";
};

# Sanity check #2
die "pwd doesn't look like a Debian source package ..\n"
  unless (-e "debian/changelog");

# Process command line args
my $orig_args = join(" ", map { shell_quote($_) } ("git", "deborig", @ARGV));
my $overwrite = '';
my $user_version         = '';
my $user_ref             = '';
my $just_print           = '';
my $just_print_tag_names = '';
GetOptions(
    'force|f'              => \$overwrite,
    'just-print'           => \$just_print,
    'just-print-tag-names' => \$just_print_tag_names,
    'version=s'            => \$user_version
) || usage();

if (scalar @ARGV == 1) {
    $user_ref = shift @ARGV;
} elsif (scalar @ARGV >= 2
    || ($just_print && $just_print_tag_names)) {
    usage();
}

# Extract source package name from d/changelog and either extract
# version too, or parse user-supplied version
my $version;
my $changelog = Dpkg::Changelog::Parse->changelog_parse({});
if ($user_version) {
    $version = Dpkg::Version->new($user_version);
} else {
    $version = $changelog->{Version};
}

# Sanity check #3
die "version number $version is not valid ..\n" unless $version->is_valid();

my $source           = $changelog->{Source};
my $upstream_version = $version->version();

# Sanity check #4
# Only complain if the user didn't supply a version, because the user
# is not required to include a Debian revision when they pass
# --version
die "this looks like a native package .."
  if (!$user_version && $version->is_native());

# Convert the upstream version according to DEP-14 rules
my $git_upstream_version = $upstream_version;
$git_upstream_version =~ y/:~/%_/;
$git_upstream_version =~ s/\.(?=\.|$|lock$)/.#/g;

# This list could be expanded if new conventions come into use
my @candidate_tags = (
    "$git_upstream_version", "v$git_upstream_version",
    "upstream/$git_upstream_version"
);

# Handle the --just-print-tag-names option
if ($just_print_tag_names) {
    for my $candidate_tag (@candidate_tags) {
        print "$candidate_tag\n";
    }
    exit 0;
}

# Default to gzip
my $compressor  = "gzip -cn";
my $compression = "gz";
# Now check if we can use xz
if (-e "debian/source/format") {
    open(my $format_fh, '<', "debian/source/format")
      or die "couldn't open debian/source/format for reading";
    my $format = <$format_fh>;
    chomp($format) if defined $format;
    if ($format eq "3.0 (quilt)") {
        $compressor  = "xz -c";
        $compression = "xz";
    }
    close $format_fh;
}

my $orig = "../${source}_$upstream_version.orig.tar.$compression";
die "$orig already exists: not overwriting without --force\n"
  if (-e $orig && !$overwrite && !$just_print);

if ($user_ref) {    # User told us the tag/branch to archive
     # We leave it to git-archive(1) to determine whether or not this
     # ref exists; this keeps us forward-compatible
    archive_ref_or_just_print($user_ref);
} else {    # User didn't specify a tag/branch to archive
            # Get available git tags
    my @all_tags = $git->tag();

    # See which candidate version tags are present in the repo
    my $lc           = List::Compare->new(\@all_tags, \@candidate_tags);
    my @version_tags = $lc->get_intersection();

    # If there is only one candidate version tag, we're good to go.
    # Otherwise, let the user know they can tell us which one to use
    if (scalar @version_tags > 1) {
        print STDERR "tags ", join(", ", @version_tags),
          " all exist in this repository\n";
        print STDERR
"tell me which one you want to make an orig.tar from: $orig_args TAG\n";
        exit 1;
    } elsif (scalar @version_tags < 1) {
        print STDERR "couldn't find any of the following tags: ",
          join(", ", @candidate_tags), "\n";
        print STDERR
"tell me a tag or branch head to make an orig.tar from: $orig_args COMMITTISH\n";
        exit 1;
    } else {
        my $tag = shift @version_tags;
        archive_ref_or_just_print($tag);
    }
}

sub archive_ref_or_just_print {
    my $ref = shift;

    my $cmd = [
        'git',     '-c', "tar.tar.${compression}.command=${compressor}",
        'archive', "--prefix=${source}-${upstream_version}/",
        '-o',      $orig, $ref
    ];
    if ($just_print) {
        print "$ref\n";
        print "$orig\n";
        my @cmd_mapped = map { shell_quote($_) } @$cmd;
        print "@cmd_mapped\n";
    } else {
        my ($info_dir) = $git->rev_parse(qw|--git-path info/|);
        my ($info_attributes)
          = $git->rev_parse(qw|--git-path info/attributes|);
        my ($deborig_attributes)
          = $git->rev_parse(qw|--git-path info/attributes-deborig|);

        # sometimes the info/ dir may not exist
        mkdir $info_dir unless (-e $info_dir);

        # For compatibility with dgit, we have to override any
        # export-subst and export-ignore git attributes that might be set
        rename $info_attributes, $deborig_attributes
          if (-e $info_attributes);
        my $attributes_fh;
        unless (open($attributes_fh, '>', $info_attributes)) {
            rename $deborig_attributes, $info_attributes
              if (-e $deborig_attributes);
            die "could not open $info_attributes for writing";
        }
        print $attributes_fh "* -export-subst\n";
        print $attributes_fh "* -export-ignore\n";
        close $attributes_fh;

        spawn(
            exec       => $cmd,
            wait_child => 1,
            nocheck    => 1
        );

        # Restore situation before we messed around with git attributes
        if (-e $deborig_attributes) {
            rename $deborig_attributes, $info_attributes;
        } else {
            unlink $info_attributes;
        }
    }
}

sub usage {
    die
"usage: git deborig [--force|-f] [--just-print|--just-print-tag-names] [--version=VERSION] [COMMITTISH]\n";
}
