File export_debian_orig_from_git of Package build

#!/usr/bin/perl

use strict;

sub get_name_version {
  my $fd;
  open($fd, '<', 'debian/changelog') || die("debian/changelog: $!\n");
  while (<$fd>) {
    chomp;
    return ($1, $2) if /^(\S+)\s+\(([^\)]+)\)/;
  }
}

sub has_git_branch {
  my ($branch) = @_;
  system('git', 'show-ref', '-q', '--verify', $branch);
  return $? == 0 ? 1 : 0
}

sub get_pristine_commit {
  my ($tarfile) = @_;
  my $pristine_branch;
  $pristine_branch = 'pristine-tar' if !$pristine_branch && has_git_branch('refs/heads/pristine-tar');
  $pristine_branch = 'origin/pristine-tar' if !$pristine_branch && has_git_branch('refs/remotes/origin/pristine-tar');
  return unless $pristine_branch;
  my $fd;
  open ($fd, '-|', 'git', 'log', '--pretty=format:%H:%s', $pristine_branch);
  while (<$fd>) {
    chomp;
    next unless /^([0-9a-f]+):.* data for (.*)/;
    my ($id, $tar) = ($1, $2);
    next unless $tar =~ /^\Q$tarfile\E(\.(gz|xz|bz2))?$/s;
    1 while <$fd>;
    return ($id, $tar);
  }
  close($fd) || die("git log: $?\n");
}

sub export_blob {
  my ($blob, $out) = @_;
  my $fd;
  my $pid = open($fd, '|-');
  die("fork: $!\n") unless defined $pid;
  if (!$pid) {
    open(STDIN, '<', '/dev/null') || die("/dev/null: $!\n");
    open(STDOUT, '>', $out) || die("$out: $!\n");
    exec 'git', 'cat-file', 'blob', $blob;
  }
  close($fd) || die("git cat-file: $?\n");
}

sub list_commit {
  my ($commit) = @_;
  my %files;
  my $fd;
  open ($fd, '-|', 'git', 'ls-tree', $commit) || die("git: $!\n");
  while (<$fd>) {
    chomp;
    my @s = split(' ', $_, 4);
    $files{$s[3]} = $s[2] if @s == 4 && $s[2] =~ /^[0-9a-f]+/;
  }
  close($fd) || die("git ls-tree $commit: $?\n");
  return \%files;
}

sub export_pristine_commit {
  my ($commit, $tarfile, $dir) = @_;
  my $files = list_commit($commit);
  for my $f ('.delta', '.id', '.asc') {
    my $blob = $files->{"$tarfile$f"};
    export_blob($blob, "$dir/$tarfile$f") if $blob;
  }
}

my ($from, $to) = @ARGV;
$from ||= '.';
$to ||= 'build.origtar';

$from eq '.' || chdir($from) || die("chdir $from: $!\n");
die("$from/debian: $!\n") unless -e "debian";
die("$from/debian: Not a directory\n") unless -d "debian";
-d $to || mkdir($to) || die("mkdir $to: $!\n");

# get version from changelog
my ($name, $version) = get_name_version();
die("Could not determine name and version\n") unless defined $version;
$version =~ s/-.*?$//;	# strip release

my $tarfile = "${name}_$version.orig.tar";

my $tag = $version;
$tag =~ s/~/_/g;
$tag =~ s/:/%/g;
$tag = "upstream/$tag";

# export the (uncompressed) tar archive
system('git', 'archive', '--format=tar', "--prefix=$name-$version/", "--output=$to/$tarfile", $tag) && die("git archive $tag failed: $?\n");

# export pristine-tar entries if present
my ($pristine_commit, $pristine_tar) = get_pristine_commit($tarfile);
export_pristine_commit($pristine_commit, $pristine_tar, $to) if $pristine_commit;