devscripts/scripts/git-deborig.pl

#!/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/>.

=head1 NAME

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

=head1 SYNOPSIS

B<git deborig> [B<--force>|B<-f>] [B<--just-print>|B<--just-print-tag-names>] [B<--version=>I<VERSION>] [I<COMMITTISH>]

=head1 DESCRIPTION

B<git-deborig> tries to produce the orig.tar you need for your upload
by calling git-archive(1) on an existing git tag or branch head.  It
was written with the dgit-maint-merge(7) workflow in mind, but can be
used with other workflows.

B<git-deborig> will try several common tag names.  If this fails, or
if more than one of those common tags are present, you can specify the
tag or branch head to archive on the command line (I<COMMITTISH> above).

B<git-deborig> will override gitattributes(5) that would cause the
contents of the tarball generated by git-archive(1) not to be
identical with the commitish archived: the B<export-subst> and
B<export-ignore> attributes.

B<git-deborig> should be invoked from the root of the git repository,
which should contain I<debian/changelog>.

=head1 OPTIONS

=over 4

=item B<-f>|B<--force>

Overwrite any existing orig.tar in the parent directory.

=item B<--just-print>

Instead of actually invoking git-archive(1), output information about
how it would be invoked.  Ignores I<--force>.

Note that running the git-archive(1) invocation outputted with this
option may not produce the same output.  This is because
B<git-deborig> takes care to disables git attributes otherwise heeded
by git-archive(1), as detailed above.

=item B<--just-print-tag-names>

Instead of actually invoking git-archive(1), or even checking which
tags exist, print the tag names we would consider for the upstream
version number in the first entry in the Debian changelog, or that
supplied with B<--version>.

=item B<--version=>I<VERSION>

Instead of reading the new upstream version from the first entry in
the Debian changelog, use I<VERSION>.

=back

=head1 SEE ALSO

git-archive(1), dgit-maint-merge(7), dgit-maint-debrebase(7)

=head1 AUTHOR

B<git-deborig> was written by Sean Whitton <spwhitton@spwhitton.name>.

=cut

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";
}