3 # Integration between git and Debian-style archives
5 # Copyright (C)2013 Ian Jackson
7 # This program is free software: you can redistribute it and/or modify
8 # it under the terms of the GNU General Public License as published by
9 # the Free Software Foundation, either version 3 of the License, or
10 # (at your option) any later version.
12 # This program is distributed in the hope that it will be useful,
13 # but WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program. If not, see <http://www.gnu.org/licenses/>.
25 use Dpkg::Control::Hash;
29 our $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/';
37 our $aliothname = 'iwj@git.debian.org';
38 our $aliothpath = '/git/dgit-repos';
39 our $alioth_git = "git+ssh://$aliothname/$aliothpath";
40 our $alioth_sshtestbodge = [$aliothname,$aliothpath];
42 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
45 our (@dget) = qw(dget);
46 our (@dput) = qw(dput);
47 our (@debsign) = qw(debsign);
50 open DEBUG, ">/dev/null" or die $!;
52 our %opts_opt_map = ('dget' => \@dget,
54 'debsign' => \@debsign);
56 our $remotename = 'dgit';
57 our $ourdscfield = 'Vcs-Git-Master';
58 our $branchprefix = 'dgit';
60 sub uploadbranch () { return "$branchprefix/$suite"; }
61 sub lref ($) { return "refs/heads/$_[0]"; }
62 sub rref ($) { return "refs/remotes/$remotename/$_[0]"; }
63 sub debiantag ($) { return "debian/$_[0]"; }
69 $ua = LWP::UserAgent->new();
72 print "fetching @_...\n";
73 my $r = $ua->get(@_) or die $!;
74 die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
75 return $r->decoded_content();
78 our ($dscdata,$dscurl,$dsc);
83 print $fh $intro or die $!;
87 if (s{['\\]}{\\$&}g || m{\s} || m{[^-_./0-9a-z]}i) {
88 print $fh " '$_'" or die $!;
90 print $fh " $_" or die $!;
93 print $fh "\n" or die $!;
97 printcmd(\*DEBUG,"+",@_);
99 die "@_ $! $?" if system @_;
102 sub cmdoutput_errok {
103 printcmd(\*DEBUG,"|",@_);
104 open P, "-|", @_ or die $!;
107 { local $/ = undef; $d = <P>; }
109 close P or return undef;
115 my $d = cmdoutput_errok @_;
116 defined $d or die "@_ $? $!";
121 printcmd(\*STDOUT,"#",@_);
124 sub runcmd_ordryrun {
133 my $c = Dpkg::Control::Hash->new();
134 $c->load(@_) or return undef;
139 my $c = Dpkg::Control::Hash->new();
140 my $p = new IO::Handle;
141 open $p, '-|', qw(dpkg-parsechangelog) or die $!;
143 $?=0; $!=0; close $p or die "$! $?";
150 $rmad ||= cmdoutput qw(rmadison -asource),"-s$suite",$package;
151 $rmad =~ m/^ \s*( [^ \t|]+ )\s* \|
152 \s*( [^ \t|]+ )\s* \|
153 \s*( [^ \t|]+ )\s* \|
154 \s*( [^ \t|]+ )\s* /x or die "$rmad $?";
155 $1 eq $package or die "$rmad $package ?";
158 # madison canonicalises for us
159 print "canonical suite name for $suite is $3\n";
162 $4 eq 'source' or die "$rmad ?";
166 sub canonicalise_suite () {
170 sub get_archive_dsc () {
171 my $vsn = askmadison();
172 # fixme madison does not show us the component
173 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
174 $dscurl = "$mirror/pool/main/$prefix/$package/${package}_$vsn.dsc";
175 $dscdata = url_get($dscurl);
176 my $dscfh = new IO::File \$dscdata, '<' or die $!;
177 print DEBUG Dumper($dscdata);
178 $dsc = Dpkg::Control::Hash->new(allow_pgp=>1);
179 $dsc->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
180 print DEBUG Dumper($dsc);
181 my $fmt = $dsc->{Format};
182 die "unsupported format $fmt, sorry\n" unless $format_ok{$fmt};
185 sub check_for_git () {
188 "ssh $alioth_sshtestbodge->[0] '".
189 " set -e; cd $alioth_sshtestbodge->[1];".
190 " if test -d $package.git; then echo 1; else echo 0; fi".
192 print DEBUG "$cmd\n";
193 open P, "$cmd |" or die $!;
195 my $r = <P>; close P;
196 print DEBUG ">$r<\n";
197 die "$r $! $?" unless $r =~ m/^[01]$/;
201 our ($dsc_hash,$upload_hash);
203 our $ud = '.git/dgit/unpack';
211 sub mktree_in_ud_from_only_subdir () {
212 # changes into the subdir
215 $dirs[0] =~ m#^([^/]+)/\.$# or die;
217 chdir $dir or die "$dir $!";
219 die $! unless $!==&ENOENT;
220 runcmd qw(git init -q);
221 rmtree('.git/objects');
222 symlink '../../../../objects','.git/objects' or die $!;
223 runcmd @git, qw(add -Af);
224 my $tree = cmdoutput @git, qw(write-tree);
225 chomp $tree; $tree =~ m/^\w+$/ or die "$tree ?";
231 m/^\w+ \d+ (\S+)$/ or die "$_ ?";
233 } grep m/\S/, split /\n/, ($dsc->{'Checksums-Sha256'} || $dsc->{Files});
236 sub is_orig_file ($) {
238 m/\.orig(?:-\w+)?\.tar\.\w+$/;
241 sub generate_commit_from_dsc () {
245 foreach my $f (dsc_files()) {
246 die if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
248 link "../../../$f", $f
252 runcmd @dget, qw(--), $dscurl;
253 foreach my $f (grep { is_orig_file($_) } @files) {
254 link $f, "../../../../$f"
258 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
259 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
260 my $clogp = parsecontrol('../changelog.tmp','changelog') or die;
261 my $date = cmdoutput qw(date), '+%s %z', qw(-d),$clogp->{Date};
262 my $author = $clogp->{Maintainer};
263 $author =~ s#,.*##ms;
264 my $authline = "$author $date";
265 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or die $authline;
266 open C, ">../commit.tmp" or die $!;
267 print C "tree $tree\n" or die $!;
268 print C "parent $upload_hash\n" or die $! if $upload_hash;
269 print C <<END or die $!;
275 # imported by dgit from the archive
278 print "synthesised git commit from .dsc $clogp->{Version}\n";
279 my $commithash = cmdoutput @git, qw(hash-object -w -t commit ../commit.tmp);
280 chdir '../../../..' or die $!;
281 cmdoutput @git, qw(update-ref -m),"dgit synthesise $clogp->{Version}",
282 'DGIT_ARCHIVE', $commithash;
283 cmdoutput @git, qw(log -n2), $commithash;
284 # ... gives git a chance to complain if our commit is malformed
285 my $outputhash = $commithash;
287 chdir "$ud/$dir" or die $!;
288 runcmd @git, qw(reset --hard), $upload_hash;
289 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
290 my $oldclogp = Dpkg::Control::Hash->new();
291 $oldclogp->parse('../changelogold.tmp','previous changelog') or die;
293 version_compare_string($oldclogp->{Version}, $clogp->{Version});
295 # git upload/ is earlier vsn than archive, use archive
296 } elsif ($vcmp >= 0) {
297 print STDERR <<END or die $!;
298 Version actually in archive: $clogp->{Version} (older)
299 Last allegedly pushed/uploaded: $oldclogp->{Version} (newer or same)
300 Perhaps the upload is stuck in incoming. Using the version from git.
303 die "version in archive is same as version in git".
304 " to-be-uploaded (upload/) branch but archive".
305 " version hash no commit hash?!\n";
307 chdir '../../../..' or die $!;
313 sub ensure_we_have_orig () {
314 foreach my $f (dsc_files()) {
315 next unless is_orig_file($f);
317 die "$f ?" unless -f _;
319 die "$f $!" unless $!==&ENOENT;
321 my $origurl = $dscurl;
322 $origurl =~ s{/[^/]+$}{};
324 die "$f ?" unless $f =~ m/^${package}_/;
325 die "$f ?" if $f =~ m#/#;
326 runcmd_ordryrun qw(sh -ec),'cd ..; exec "$@"','x',
332 return cmdoutput @git, qw(rev-parse), "$_[0]~0";
335 sub is_fast_fwd ($$) {
336 my ($ancestor,$child) = @_;
337 my $mb = cmdoutput @git, qw(merge-base), $dsc_hash, $upload_hash;
338 return rev_parse($mb) eq rev_parse($ancestor);
341 sub fetch_from_archive () {
342 # ensures that rref(uploadbranch()) is what is actually in the archive,
344 my $upload_ref = rref(uploadbranch());
346 cmdoutput_errok @git, qw(show-ref --heads), $upload_ref;
348 die $? unless ($?==0 && chomp $upload_hash)
349 or ($?==256 && !length $upload_hash);
352 if (defined $dsc_hash) {
353 die "missing git history even though dsc has hash"
356 ensure_we_have_orig();
358 $hash = generate_commit_from_dsc();
361 die "not fast forward on last upload branch!".
362 " (archive's version left in DGIT_ARCHIVE)"
363 unless is_fast_fwd($dsc_hash, $upload_hash);
365 if ($upload_hash ne $hash) {
366 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', $upload_ref, $hash);
370 dryrun_report @upd_cmd;
376 die "dry run makes no sense with clone" if $dryrun;
378 $dsc_hash = $dsc->{$ourdscfield};
379 if (defined $dsc_hash) {
380 $dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
382 print "last upload to archive specified git hash\n";
384 print "last upload to archive has NO git hash\n";
386 my $dstdir = "$package";
387 my $branch = uploadbranch();
388 if (check_for_git()) {
389 print "cloning existing git history\n";
390 runcmd @git, qw(clone --origin),$remotename, qw(-b), $branch, '--',
391 "$alioth_git/$package.git", $dstdir;
392 chdir "$dstdir" or die "$dstdir $!";
393 fetch_from_archive();
394 runcmd @git, qw(reset --hard), rref(uploadbranch());
396 print "starting new git history\n";
397 mkdir $dstdir or die "$dstdir $!";
398 chdir "$dstdir" or die "$dstdir $!";
399 runcmd @git, qw(init -q);
400 open H, "> .git/HEAD" or die $!;
401 print H "ref: ".lref(uploadbranch())."\n" or die $!;
403 runcmd @git, qw(remote add), $remotename, "$alioth_git/$package.git";
404 runcmd "git config branch.$branch.remote $remotename";
405 runcmd "git config branch.$branch.merge ".lref(uploadbranch());
406 my $newhash = generate_commit_from_dsc();
407 runcmd @git, qw(reset --hard), $newhash;
409 print "ready for work in $dstdir\n";
414 if (check_for_git()) {
415 runcmd_ordryrun @git, qw(fetch -p),$remotename,
416 '+refs/heads/*:refs/remotes/origin/*';
418 fetch_from_archive();
423 runcmd_ordryrun @git, qw(merge -m),"Merge from $suite [dgit]",
424 lref(uploadbranch());
428 runcmd @git, qw(diff --quiet HEAD);
429 my $clogp = parsechangelog();
430 $package = $clogp->{Source};
431 my $dscfn = "${package}_$clogp->{Version}.dsc";
432 stat "../$dscfn" or die "$dscfn $!";
433 $dsc = parsecontrol("../$dscfn");
436 print "checking that $dscfn corresponds to HEAD\n";
437 runcmd qw(dpkg-source -x --), "../../../../$dscfn";
438 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
439 chdir '../../../..' or die $!;
440 runcmd @git, qw(diff --exit-code), $tree;
442 #do fast forward check and maybe fake merge
443 # if (!is_fast_fwd(mainbranch
444 # runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
445 # map { lref($_).":".rref($_) }
447 $dsc->{$ourdscfield} = rev_parse('HEAD');
448 $dsc->save("../$dscfn.tmp") or die $!;
450 rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
452 print "[new .dsc left in $dscfn.tmp]\n";
455 my $pat = "../${package}_$clogp->{Version}_*.changes";
457 die "$pat ?" unless @cs==1;
458 ($changesfile) = @cs;
460 my $tag = debiantag($dsc->{Version});
461 if (!check_for_git()) {
462 runcmd_ordryrun qw(ssh),$alioth_sshtestbodge->[0],
463 "set -e; cd $alioth_sshtestbodge->[1];".
464 " mkdir -p $package.git;".
466 " if ! test -d objects; then git init --bare; fi";
468 runcmd_ordryrun @git, qw(push),$remotename,"HEAD:".lref(uploadbranch());
470 my @tag_cmd = (@git, qw(tag -s -m),
471 "Release $dsc->{Version} for $suite [dgit]");
472 push @tag_cmd, qw(-u),$keyid if defined $keyid;
474 runcmd_ordryrun @tag_cmd;
475 my @debsign_cmd = @debsign;
476 push @debsign_cmd, "-k$keyid" if defined $keyid;
477 push @debsign_cmd, $changesfile;
478 runcmd_ordryrun @debsign_cmd;
480 runcmd_ordryrun @git, qw(push),$remotename,"refs/tags/$tag";
481 runcmd_ordryrun @dput, $changesfile;
488 ($package,$suite) = @ARGV;
496 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
498 if ($branch =~ m#^refs/heads/$branchprefix/([^/.]+)$#o) {
505 sub fetchpullargs () {
506 my $clogp = parsechangelog();
507 $package = $clogp->{Source};
509 $suite = branchsuite();
510 $suite ||= $clogp->{Distribution};
511 canonicalise_suite();
512 print "fetching from suite $suite\n";
515 canonicalise_suite();
532 my $clogp = parsechangelog();
533 $package = $clogp->{Source};
535 $suite = $clogp->{Distribution};
536 canonicalise_suite();
544 my $clogp = parsechangelog();
545 $suite = $clogp->{Distribution};
546 $package = $clogp->{Source};
547 canonicalise_suite();
549 qw(git-buildpackage -us -uc --git-no-sign-tags),
550 "--git-debian-branch=".uploadbranch(),
557 last unless $ARGV[0] =~ m/^-/;
561 if (m/^--dry-run$/) {
563 } elsif (m/^--no-sign$/) {
565 } elsif (m/^--(\w+)=(.*)/s && ($om = $opts_opt_map{$1})) {
567 } elsif (m/^--(\w+):(.*)/s && ($om = $opts_opt_map{$1})) {
577 open DEBUG, ">&STDERR" or die $!;
578 } elsif (s/^-c(.*=.*)//s) {
580 } elsif (s/^-C(.*)//s) {
582 } elsif (s/^-k(.*)//s) {
594 my $cmd = shift @ARGV;
597 { no strict qw(refs); &{"cmd_$cmd"}(); }