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;
36 our $existing_package = 'dpkg';
38 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
41 our (@dget) = qw(dget);
42 our (@dput) = qw(dput);
43 our (@debsign) = qw(debsign);
47 open DEBUG, ">/dev/null" or die $!;
49 our %opts_opt_map = ('dget' => \@dget,
51 'debsign' => \@debsign);
53 our $remotename = 'dgit';
54 our $ourdscfield = 'Vcs-Dgit-Master';
55 our $branchprefix = 'dgit';
57 sub lbranch () { return "$branchprefix/$suite"; }
58 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
59 sub lref () { return "refs/heads/".lbranch(); }
60 sub lrref () { return "refs/remotes/$remotename/$suite"; }
61 sub rrref () { return "refs/$branchprefix/$suite"; }
62 sub debiantag ($) { return "debian/$_[0]"; }
66 return "+".rrref().":".lrref();
73 $ua = LWP::UserAgent->new();
76 print "downloading @_...\n";
77 my $r = $ua->get(@_) or die $!;
78 die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
79 return $r->decoded_content();
82 our ($dscdata,$dscurl,$dsc);
87 print $fh $intro or die $!;
91 if (s{['\\]}{\\$&}g || m{\s} || m{[^-_./0-9a-z]}i) {
92 print $fh " '$_'" or die $!;
94 print $fh " $_" or die $!;
97 print $fh "\n" or die $!;
101 printcmd(\*DEBUG,"+",@_) if $debug>0;
103 die "@_ $! $?" if system @_;
106 sub cmdoutput_errok {
107 die Dumper(\@_)." ?" if grep { !defined } @_;
108 printcmd(\*DEBUG,"|",@_) if $debug>0;
109 open P, "-|", @_ or die $!;
112 { local $/ = undef; $d = <P>; }
114 close P or return undef;
120 my $d = cmdoutput_errok @_;
121 defined $d or die "@_ $? $!";
126 printcmd(\*STDOUT,"#",@_);
129 sub runcmd_ordryrun {
137 our %defcfg = ('dgit.default.distro' => 'debian',
138 'dgit.default.username' => '',
139 'dgit.default.archive-query-default-component' => 'main',
140 'dgit.default.ssh' => 'ssh',
141 'dgit-distro.debian.git-host' => 'git.debian.org',
142 'dgit-distro.debian.git-proto' => 'git+ssh://',
143 'dgit-distro.debian.git-path' => '/git/dgit-repos',
144 'dgit-distro.debian.git-check' => 'ssh-cmd',
145 'dgit-distro.debian.git-create' => 'ssh-cmd',
146 'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/');
152 local ($debug) = $debug-1;
153 $v = cmdoutput_errok(@git, qw(config --), $c);
161 my $dv = $defcfg{$c};
162 return $dv if defined $dv;
167 sub access_distro () {
168 return cfg("dgit-suite.$suite.distro",
169 "dgit.default.distro");
174 my $distro = access_distro();
175 my $value = cfg("dgit-distro.$distro.$key",
176 "dgit.default.$key");
180 sub access_gituserhost () {
181 my $user = access_cfg('git-user');
182 my $host = access_cfg('git-host');
183 return defined($user) && length($user) ? "$user\@$host" : $host;
186 sub access_giturl () {
187 my $url = access_cfg('git-url');
190 access_cfg('git-proto').
191 access_gituserhost().
192 access_cfg('git-path');
194 return "$url/$package.git";
198 my $c = Dpkg::Control::Hash->new();
199 $c->load(@_) or return undef;
204 my $c = Dpkg::Control::Hash->new();
205 my $p = new IO::Handle;
206 open $p, '-|', qw(dpkg-parsechangelog) or die $!;
208 $?=0; $!=0; close $p or die "$! $?";
214 sub archive_query () {
215 my $query = access_cfg('archive-query');
216 $query ||= "madison:".access_distro();
217 $query =~ s/^(\w+):// or die "$query ?";
220 die unless $proto eq 'madison';
221 $rmad{$package} ||= cmdoutput
222 qw(rmadison -asource),"-s$suite","-u$url",$package;
223 my $rmad = $rmad{$package};
227 $rmad =~ m{^ \s*( [^ \t|]+ )\s* \|
228 \s*( [^ \t|]+ )\s* \|
229 \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
230 \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
231 $1 eq $package or die "$rmad $package ?";
234 # madison canonicalises for us
235 print "canonical suite name for $suite is $3\n";
242 $component = access_cfg('archive-query-default-component');
244 $5 eq 'source' or die "$rmad ?";
245 my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
246 my $subpath = "/pool/$component/$prefix/$package/${package}_$vsn.dsc";
247 return ($vsn,$subpath);
250 sub canonicalise_suite () {
251 archive_query() or die;
254 sub get_archive_dsc () {
255 my ($vsn,$subpath) = archive_query();
256 if (!defined $vsn) { $dsc=undef; return undef; }
257 $dscurl = access_cfg('mirror').$subpath;
258 $dscdata = url_get($dscurl);
259 my $dscfh = new IO::File \$dscdata, '<' or die $!;
260 print DEBUG Dumper($dscdata) if $debug>1;
261 $dsc = Dpkg::Control::Hash->new(allow_pgp=>1);
262 $dsc->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
263 print DEBUG Dumper($dsc) if $debug>1;
264 my $fmt = $dsc->{Format};
265 die "unsupported format $fmt, sorry\n" unless $format_ok{$fmt};
268 sub check_for_git () {
270 my $how = access_cfg('git-check');
271 if ($how eq 'ssh-cmd') {
273 (access_cfg('ssh'),access_gituserhost(),
274 " set -e; cd ".access_cfg('git-path').";".
275 " if test -d $package.git; then echo 1; else echo 0; fi");
276 print DEBUG "got \`$r'\n";
277 die "$r $! $?" unless $r =~ m/^[01]$/;
280 die "unknown git-check $how ?";
284 sub create_remote_git_repo () {
285 my $how = access_cfg('git-create');
286 if ($how eq 'ssh-cmd') {
288 (access_cfg('ssh'),access_gituserhost(),
289 "set -e; cd ".access_cfg('git-path').";".
290 " mkdir -p $package.git;".
292 " if ! test -d objects; then git init --bare; fi");
294 die "unknown git-create $how ?";
298 our ($dsc_hash,$upload_hash);
300 our $ud = '.git/dgit/unpack';
308 sub mktree_in_ud_from_only_subdir () {
309 # changes into the subdir
312 $dirs[0] =~ m#^([^/]+)/\.$# or die;
314 chdir $dir or die "$dir $!";
316 die $! unless $!==&ENOENT;
317 runcmd qw(git init -q);
318 rmtree('.git/objects');
319 symlink '../../../../objects','.git/objects' or die $!;
320 runcmd @git, qw(add -Af);
321 my $tree = cmdoutput @git, qw(write-tree);
322 chomp $tree; $tree =~ m/^\w+$/ or die "$tree ?";
328 m/^\w+ \d+ (\S+)$/ or die "$_ ?";
330 } grep m/\S/, split /\n/, ($dsc->{'Checksums-Sha256'} || $dsc->{Files});
333 sub is_orig_file ($) {
335 m/\.orig(?:-\w+)?\.tar\.\w+$/;
338 sub generate_commit_from_dsc () {
342 foreach my $f (dsc_files()) {
343 die if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
345 link "../../../$f", $f
349 runcmd @dget, qw(--), $dscurl;
350 foreach my $f (grep { is_orig_file($_) } @files) {
351 link $f, "../../../../$f"
355 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
356 runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
357 my $clogp = parsecontrol('../changelog.tmp','changelog') or die;
358 my $date = cmdoutput qw(date), '+%s %z', qw(-d),$clogp->{Date};
359 my $author = $clogp->{Maintainer};
360 $author =~ s#,.*##ms;
361 my $authline = "$author $date";
362 $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or die $authline;
363 open C, ">../commit.tmp" or die $!;
364 print C "tree $tree\n" or die $!;
365 print C "parent $upload_hash\n" or die $! if $upload_hash;
366 print C <<END or die $!;
372 # imported by dgit from the archive
375 my $commithash = cmdoutput @git, qw(hash-object -w -t commit ../commit.tmp);
376 print "synthesised git commit from .dsc $clogp->{Version}\n";
377 chdir '../../../..' or die $!;
378 cmdoutput @git, qw(update-ref -m),"dgit synthesise $clogp->{Version}",
379 'DGIT_ARCHIVE', $commithash;
380 cmdoutput @git, qw(log -n2), $commithash;
381 # ... gives git a chance to complain if our commit is malformed
382 my $outputhash = $commithash;
384 chdir "$ud/$dir" or die $!;
385 runcmd @git, qw(reset --hard), $upload_hash;
386 runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
387 my $oldclogp = Dpkg::Control::Hash->new();
388 $oldclogp->parse('../changelogold.tmp','previous changelog') or die;
390 version_compare_string($oldclogp->{Version}, $clogp->{Version});
392 # git upload/ is earlier vsn than archive, use archive
393 } elsif ($vcmp >= 0) {
394 print STDERR <<END or die $!;
395 Version actually in archive: $clogp->{Version} (older)
396 Last allegedly pushed/uploaded: $oldclogp->{Version} (newer or same)
397 Perhaps the upload is stuck in incoming. Using the version from git.
400 die "version in archive is same as version in git".
401 " to-be-uploaded (upload/) branch but archive".
402 " version hash no commit hash?!\n";
404 chdir '../../../..' or die $!;
410 sub ensure_we_have_orig () {
411 foreach my $f (dsc_files()) {
412 next unless is_orig_file($f);
414 die "$f ?" unless -f _;
416 die "$f $!" unless $!==&ENOENT;
418 my $origurl = $dscurl;
419 $origurl =~ s{/[^/]+$}{};
421 die "$f ?" unless $f =~ m/^${package}_/;
422 die "$f ?" if $f =~ m#/#;
423 runcmd_ordryrun qw(sh -ec),'cd ..; exec "$@"','x',
429 return cmdoutput @git, qw(rev-parse), "$_[0]~0";
432 sub is_fast_fwd ($$) {
433 my ($ancestor,$child) = @_;
434 my $mb = cmdoutput @git, qw(merge-base), $ancestor, $child;
435 return rev_parse($mb) eq rev_parse($ancestor);
438 sub git_fetch_us () {
439 die "cannot dry run with fetch" if $dryrun;
440 runcmd @git, qw(fetch),access_giturl(),fetchspec();
443 sub fetch_from_archive () {
444 # ensures that lrref() is what is actually in the archive,
446 get_archive_dsc() or return 0;
447 $dsc_hash = $dsc->{$ourdscfield};
448 if (defined $dsc_hash) {
449 $dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
451 print "last upload to archive specified git hash\n";
453 print "last upload to archive has NO git hash\n";
457 cmdoutput_errok @git, qw(show-ref --heads), lrref();
459 die unless chomp $upload_hash;
466 if (defined $dsc_hash) {
467 die "missing git history even though dsc has hash"
470 ensure_we_have_orig();
472 $hash = generate_commit_from_dsc();
475 die "not fast forward on last upload branch!".
476 " (archive's version left in DGIT_ARCHIVE)"
477 unless is_fast_fwd($dsc_hash, $upload_hash);
479 if ($upload_hash ne $hash) {
480 my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
484 dryrun_report @upd_cmd;
492 die "dry run makes no sense with clone" if $dryrun;
493 mkdir $dstdir or die "$dstdir $!";
494 chdir "$dstdir" or die "$dstdir $!";
495 runcmd @git, qw(init -q);
496 runcmd @git, qw(config), "remote.$remotename.fetch", fetchspec();
497 open H, "> .git/HEAD" or die $!;
498 print H "ref: ".lref()."\n" or die $!;
500 runcmd @git, qw(remote add), 'origin', access_giturl();
501 if (check_for_git()) {
502 print "fetching existing git history\n";
504 runcmd @git, qw(fetch origin);
506 print "starting new git history\n";
508 fetch_from_archive() or die;
509 runcmd @git, qw(reset --hard), lrref();
510 print "ready for work in $dstdir\n";
514 if (check_for_git()) {
517 fetch_from_archive() or die;
522 runcmd_ordryrun @git, qw(merge -m),"Merge from $suite [dgit]",
527 runcmd @git, qw(diff --quiet HEAD);
528 my $clogp = parsechangelog();
529 $package = $clogp->{Source};
530 my $dscfn = "${package}_$clogp->{Version}.dsc";
531 stat "../$dscfn" or die "$dscfn $!";
532 $dsc = parsecontrol("../$dscfn");
535 print "checking that $dscfn corresponds to HEAD\n";
536 runcmd qw(dpkg-source -x --), "../../../../$dscfn";
537 my ($tree,$dir) = mktree_in_ud_from_only_subdir();
538 chdir '../../../..' or die $!;
539 runcmd @git, qw(diff --exit-code), $tree;
541 #do fast forward check and maybe fake merge
542 # if (!is_fast_fwd(mainbranch
543 # runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
544 # map { lref($_).":".rref($_) }
546 $dsc->{$ourdscfield} = rev_parse('HEAD');
547 $dsc->save("../$dscfn.tmp") or die $!;
549 rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
551 print "[new .dsc left in $dscfn.tmp]\n";
554 my $pat = "../${package}_$clogp->{Version}_*.changes";
556 die "$pat ?" unless @cs==1;
557 ($changesfile) = @cs;
559 my $tag = debiantag($dsc->{Version});
560 if (!check_for_git()) {
561 create_remote_git_repo();
563 runcmd_ordryrun @git, qw(push),access_giturl(),"HEAD:".rrref();
565 my @tag_cmd = (@git, qw(tag -s -m),
566 "Release $dsc->{Version} for $suite [dgit]");
567 push @tag_cmd, qw(-u),$keyid if defined $keyid;
569 runcmd_ordryrun @tag_cmd;
570 my @debsign_cmd = @debsign;
571 push @debsign_cmd, "-k$keyid" if defined $keyid;
572 push @debsign_cmd, $changesfile;
573 runcmd_ordryrun @debsign_cmd;
575 runcmd_ordryrun @git, qw(push),access_giturl(),"refs/tags/$tag";
576 my $host = access_cfg('upload-host');
577 my @hostarg = defined($host) ? ($host,) : ();
578 runcmd_ordryrun @dput, @hostarg, $changesfile;
584 die if defined $package;
587 } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
588 ($package,$suite) = @ARGV;
589 } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
590 ($package,$dstdir) = @ARGV;
592 ($package,$suite,$dstdir) = @ARGV;
596 $dstdir ||= "$package";
601 my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
603 if ($branch =~ m#$lbranch_re#o) {
610 sub fetchpullargs () {
611 if (!defined $package) {
612 my $sourcep = parsecontrol('debian/control');
613 $package = $sourcep->{Source};
616 $suite = branchsuite();
618 my $clogp = parsechangelog();
619 $suite = $clogp->{Distribution};
621 canonicalise_suite();
622 print "fetching from suite $suite\n";
625 canonicalise_suite();
645 die if defined $package;
646 my $clogp = parsechangelog();
647 $package = $clogp->{Source};
649 $suite = $clogp->{Distribution};
651 local ($package) = $existing_package; # this is a hack
652 canonicalise_suite();
657 if (fetch_from_archive()) {
658 is_fast_fwd(lrref(), 'HEAD') or die;
660 die unless $new_package;
666 # we pass further options and args to git-buildpackage
667 die if defined $package;
668 my $clogp = parsechangelog();
669 $suite = $clogp->{Distribution};
670 $package = $clogp->{Source};
672 qw(git-buildpackage -us -uc --git-no-sign-tags),
673 '--git-builder=dpkg-buildpackage -i\.git/ -I.git',
674 "--git-debian-branch=".lbranch(),
681 last unless $ARGV[0] =~ m/^-/;
685 if (m/^--dry-run$/) {
687 } elsif (m/^--no-sign$/) {
689 } elsif (m/^--new$/) {
691 } elsif (m/^--(\w+)=(.*)/s && ($om = $opts_opt_map{$1})) {
693 } elsif (m/^--(\w+):(.*)/s && ($om = $opts_opt_map{$1})) {
695 } elsif (m/^--existing-package=(.*)/s) {
696 $existing_package = $1;
705 open DEBUG, ">&STDERR" or die $!;
709 } elsif (s/^-c(.*=.*)//s) {
711 } elsif (s/^-C(.*)//s) {
713 } elsif (s/^-k(.*)//s) {
725 my $cmd = shift @ARGV;
727 { no strict qw(refs); &{"cmd_$cmd"}(); }