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
194
195
196
197
198
|
#!/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;
# 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 && $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) {
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}/",
'-o', $orig, $ref
];
if ($just_print) {
print "$ref\n";
print "$orig\n";
print shellquote(@$cmd)."\n";
} else {
my $info_dir = cmdoutput qw(git rev-parse --git-path info/);
my $info_attributes
= cmdoutput qw(git rev-parse --git-path info/attributes);
my $deborig_attributes
= cmdoutput qw(git rev-parse --git-path info/attributes-deborig);
# sometimes the info/ dir may not exist
-e or mkdir for $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";
}
|
