1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
#!/usr/bin/perl
# git-deborig -- try to produce Debian orig.tar using git-archive(1)
# Copyright (C) 2016-2019, 2025 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 Debian::Dgit::GDP;
use strict;
use warnings;
use Getopt::Long;
use Debian::Dgit::Core;
use Dpkg::Changelog::Parse;
use Dpkg::IPC;
use Dpkg::Version;
use POSIX;
# Sanity check #1
(cmdoutput_errok qw(git rev-parse --git-dir))
// 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 = shellquote qw(git deborig), @ARGV;
my ($overwrite, $user_version, $user_ref, $just_print, $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 (@ARGV == 1) {
$user_ref = shift @ARGV;
} elsif (@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 $changelog = Dpkg::Changelog::Parse->changelog_parse({});
my $version = $user_version
? Dpkg::Version->new($user_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 ..\n"
if !$user_version && do {
# Dpkg::Version->is_native emits a polemical warning message in forky.
# https://bugs.debian.org/cgi-bin/bugreport.cgi?bug=1123630
no warnings qw(deprecated);
is_native $version;
};
# 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) {
print "$_\n" for @candidate_tags;
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_for_each_ref("refs/tags", sub {
$_[2] =~ m#^refs/tags/#; $all_tags{$'}++;
});
# See which candidate version tags are present in the repo
my @version_tags = grep $all_tags{$_}, @candidate_tags;
# 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 (@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 (@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 {
archive_ref_or_just_print(shift @version_tags);
}
}
sub archive_ref_or_just_print {
my $ref = shift;
my $cmd = [
'git', '-c', "tar.tar.${compression}.command=${compressor}",
'archive', "--prefix=${source}-${upstream_version}/",
'--worktree-attributes',
'-o', $orig, $ref
];
if ($just_print) {
print "$ref\n";
print "$orig\n";
print shellquote(@$cmd)."\n";
} else {
# For compatibility with dgit, ans sanity, we have to override any
# transforming gitattributes that might be set.
# See GITATTRIBUTES in dgit(7).
#
# TODO #1124383. Ideally we would use .git/info/attributes in a a
# playtree instead of editing the working tree. But in the meantime
# leaving a dirty working tree is much less bad than leaving the
# user's git tree invisibly and subtly reconfigured.
my $attrs = ".gitattributes";
my $aside = "$attrs.git-deborig-aside";
rename $attrs, $aside or $!==ENOENT
or die "could not move aside $attrs: $!\n";
spawn(
exec => $cmd,
wait_child => 1,
nocheck => 1, # trixie
no_check => 1, # forky
);
rename $aside, $attrs or $!==ENOENT
or die "could not $attrs: $!\n";
}
}
sub usage {
die
"usage: git deborig [--force|-f] [--just-print|--just-print-tag-names] [--version=VERSION] [COMMITTISH]\n";
}
|
