chiark / gitweb /
5bd39e70a84b92086d35041c0f4c4fd64ddb75f7
[dgit.git] / dgit
1 #!/usr/bin/perl -w
2 # dgit
3 # Integration between git and Debian-style archives
4 #
5 # Copyright (C)2013-2016 Ian Jackson
6 #
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.
11 #
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.
16 #
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/>.
19
20 use strict;
21
22 use Debian::Dgit;
23 setup_sigwarn();
24
25 use IO::Handle;
26 use Data::Dumper;
27 use LWP::UserAgent;
28 use Dpkg::Control::Hash;
29 use File::Path;
30 use File::Temp qw(tempdir);
31 use File::Basename;
32 use Dpkg::Version;
33 use POSIX;
34 use IPC::Open2;
35 use Digest::SHA;
36 use Digest::MD5;
37 use List::Util qw(any);
38 use List::MoreUtils qw(pairwise);
39 use Carp;
40
41 use Debian::Dgit;
42
43 our $our_version = 'UNRELEASED'; ###substituted###
44
45 our @rpushprotovsn_support = qw(4 3 2); # 4 is new tag format
46 our $protovsn;
47
48 our $isuite = 'unstable';
49 our $idistro;
50 our $package;
51 our @ropts;
52
53 our $sign = 1;
54 our $dryrun_level = 0;
55 our $changesfile;
56 our $buildproductsdir = '..';
57 our $new_package = 0;
58 our $ignoredirty = 0;
59 our $rmonerror = 1;
60 our @deliberatelies;
61 our %previously;
62 our $existing_package = 'dpkg';
63 our $cleanmode;
64 our $changes_since_version;
65 our $rmchanges;
66 our $overwrite_version; # undef: not specified; '': check changelog
67 our $quilt_mode;
68 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|dpm|unapplied';
69 our $we_are_responder;
70 our $initiator_tempdir;
71 our $patches_applied_dirtily = 00;
72 our $tagformat_want;
73 our $tagformat;
74 our $tagformatfn;
75
76 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
77
78 our $suite_re = '[-+.0-9a-z]+';
79 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
80 our $orig_f_comp_re = 'orig(?:-[-0-9a-z]+)?';
81 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
82 our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
83
84 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
85 our $splitbraincache = 'dgit-intern/quilt-cache';
86
87 our (@git) = qw(git);
88 our (@dget) = qw(dget);
89 our (@curl) = qw(curl -f);
90 our (@dput) = qw(dput);
91 our (@debsign) = qw(debsign);
92 our (@gpg) = qw(gpg);
93 our (@sbuild) = qw(sbuild);
94 our (@ssh) = 'ssh';
95 our (@dgit) = qw(dgit);
96 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
97 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
98 our (@dpkggenchanges) = qw(dpkg-genchanges);
99 our (@mergechanges) = qw(mergechanges -f);
100 our (@gbp_build) = ('');
101 our (@gbp_pq) = ('gbp pq');
102 our (@changesopts) = ('');
103
104 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
105                      'curl' => \@curl,
106                      'dput' => \@dput,
107                      'debsign' => \@debsign,
108                      'gpg' => \@gpg,
109                      'sbuild' => \@sbuild,
110                      'ssh' => \@ssh,
111                      'dgit' => \@dgit,
112                      'git' => \@git,
113                      'dpkg-source' => \@dpkgsource,
114                      'dpkg-buildpackage' => \@dpkgbuildpackage,
115                      'dpkg-genchanges' => \@dpkggenchanges,
116                      'gbp-build' => \@gbp_build,
117                      'gbp-pq' => \@gbp_pq,
118                      'ch' => \@changesopts,
119                      'mergechanges' => \@mergechanges);
120
121 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
122 our %opts_cfg_insertpos = map {
123     $_,
124     scalar @{ $opts_opt_map{$_} }
125 } keys %opts_opt_map;
126
127 sub finalise_opts_opts();
128
129 our $keyid;
130
131 autoflush STDOUT 1;
132
133 our $supplementary_message = '';
134 our $need_split_build_invocation = 0;
135 our $split_brain = 0;
136
137 END {
138     local ($@, $?);
139     print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
140 }
141
142 our $remotename = 'dgit';
143 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
144 our $csuite;
145 our $instead_distro;
146
147 sub debiantag ($$) {
148     my ($v,$distro) = @_;
149     return $tagformatfn->($v, $distro);
150 }
151
152 sub debiantag_maintview ($$) { 
153     my ($v,$distro) = @_;
154     $v =~ y/~:/_%/;
155     return "$distro/$v";
156 }
157
158 sub madformat ($) { $_[0] eq '3.0 (quilt)' }
159
160 sub lbranch () { return "$branchprefix/$csuite"; }
161 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
162 sub lref () { return "refs/heads/".lbranch(); }
163 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
164 sub rrref () { return server_ref($csuite); }
165
166 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
167 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
168
169 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
170 # locally fetched refs because they have unhelpful names and clutter
171 # up gitk etc.  So we track whether we have "used up" head ref (ie,
172 # whether we have made another local ref which refers to this object).
173 #
174 # (If we deleted them unconditionally, then we might end up
175 # re-fetching the same git objects each time dgit fetch was run.)
176 #
177 # So, leach use of lrfetchrefs needs to be accompanied by arrangements
178 # in git_fetch_us to fetch the refs in question, and possibly a call
179 # to lrfetchref_used.
180
181 our (%lrfetchrefs_f, %lrfetchrefs_d);
182 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
183
184 sub lrfetchref_used ($) {
185     my ($fullrefname) = @_;
186     my $objid = $lrfetchrefs_f{$fullrefname};
187     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
188 }
189
190 sub stripepoch ($) {
191     my ($vsn) = @_;
192     $vsn =~ s/^\d+\://;
193     return $vsn;
194 }
195
196 sub srcfn ($$) {
197     my ($vsn,$sfx) = @_;
198     return "${package}_".(stripepoch $vsn).$sfx
199 }
200
201 sub dscfn ($) {
202     my ($vsn) = @_;
203     return srcfn($vsn,".dsc");
204 }
205
206 sub changespat ($;$) {
207     my ($vsn, $arch) = @_;
208     return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
209 }
210
211 our $us = 'dgit';
212 initdebug('');
213
214 our @end;
215 END { 
216     local ($?);
217     foreach my $f (@end) {
218         eval { $f->(); };
219         print STDERR "$us: cleanup: $@" if length $@;
220     }
221 };
222
223 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
224
225 sub no_such_package () {
226     print STDERR "$us: package $package does not exist in suite $isuite\n";
227     exit 4;
228 }
229
230 sub changedir ($) {
231     my ($newdir) = @_;
232     printdebug "CD $newdir\n";
233     chdir $newdir or confess "chdir: $newdir: $!";
234 }
235
236 sub deliberately ($) {
237     my ($enquiry) = @_;
238     return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
239 }
240
241 sub deliberately_not_fast_forward () {
242     foreach (qw(not-fast-forward fresh-repo)) {
243         return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
244     }
245 }
246
247 sub quiltmode_splitbrain () {
248     $quilt_mode =~ m/gbp|dpm|unapplied/;
249 }
250
251 sub opts_opt_multi_cmd {
252     my @cmd;
253     push @cmd, split /\s+/, shift @_;
254     push @cmd, @_;
255     @cmd;
256 }
257
258 sub gbp_pq {
259     return opts_opt_multi_cmd @gbp_pq;
260 }
261
262 #---------- remote protocol support, common ----------
263
264 # remote push initiator/responder protocol:
265 #  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
266 #  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
267 #  < dgit-remote-push-ready <actual-proto-vsn>
268 #
269 # occasionally:
270 #
271 #  > progress NBYTES
272 #  [NBYTES message]
273 #
274 #  > supplementary-message NBYTES          # $protovsn >= 3
275 #  [NBYTES message]
276 #
277 # main sequence:
278 #
279 #  > file parsed-changelog
280 #  [indicates that output of dpkg-parsechangelog follows]
281 #  > data-block NBYTES
282 #  > [NBYTES bytes of data (no newline)]
283 #  [maybe some more blocks]
284 #  > data-end
285 #
286 #  > file dsc
287 #  [etc]
288 #
289 #  > file changes
290 #  [etc]
291 #
292 #  > param head DGIT-VIEW-HEAD
293 #  > param csuite SUITE
294 #  > param tagformat old|new
295 #  > param maint-view MAINT-VIEW-HEAD
296 #
297 #  > previously REFNAME=OBJNAME       # if --deliberately-not-fast-forward
298 #                                     # goes into tag, for replay prevention
299 #
300 #  > want signed-tag
301 #  [indicates that signed tag is wanted]
302 #  < data-block NBYTES
303 #  < [NBYTES bytes of data (no newline)]
304 #  [maybe some more blocks]
305 #  < data-end
306 #  < files-end
307 #
308 #  > want signed-dsc-changes
309 #  < data-block NBYTES    [transfer of signed dsc]
310 #  [etc]
311 #  < data-block NBYTES    [transfer of signed changes]
312 #  [etc]
313 #  < files-end
314 #
315 #  > complete
316
317 our $i_child_pid;
318
319 sub i_child_report () {
320     # Sees if our child has died, and reap it if so.  Returns a string
321     # describing how it died if it failed, or undef otherwise.
322     return undef unless $i_child_pid;
323     my $got = waitpid $i_child_pid, WNOHANG;
324     return undef if $got <= 0;
325     die unless $got == $i_child_pid;
326     $i_child_pid = undef;
327     return undef unless $?;
328     return "build host child ".waitstatusmsg();
329 }
330
331 sub badproto ($$) {
332     my ($fh, $m) = @_;
333     fail "connection lost: $!" if $fh->error;
334     fail "protocol violation; $m not expected";
335 }
336
337 sub badproto_badread ($$) {
338     my ($fh, $wh) = @_;
339     fail "connection lost: $!" if $!;
340     my $report = i_child_report();
341     fail $report if defined $report;
342     badproto $fh, "eof (reading $wh)";
343 }
344
345 sub protocol_expect (&$) {
346     my ($match, $fh) = @_;
347     local $_;
348     $_ = <$fh>;
349     defined && chomp or badproto_badread $fh, "protocol message";
350     if (wantarray) {
351         my @r = &$match;
352         return @r if @r;
353     } else {
354         my $r = &$match;
355         return $r if $r;
356     }
357     badproto $fh, "\`$_'";
358 }
359
360 sub protocol_send_file ($$) {
361     my ($fh, $ourfn) = @_;
362     open PF, "<", $ourfn or die "$ourfn: $!";
363     for (;;) {
364         my $d;
365         my $got = read PF, $d, 65536;
366         die "$ourfn: $!" unless defined $got;
367         last if !$got;
368         print $fh "data-block ".length($d)."\n" or die $!;
369         print $fh $d or die $!;
370     }
371     PF->error and die "$ourfn $!";
372     print $fh "data-end\n" or die $!;
373     close PF;
374 }
375
376 sub protocol_read_bytes ($$) {
377     my ($fh, $nbytes) = @_;
378     $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
379     my $d;
380     my $got = read $fh, $d, $nbytes;
381     $got==$nbytes or badproto_badread $fh, "data block";
382     return $d;
383 }
384
385 sub protocol_receive_file ($$) {
386     my ($fh, $ourfn) = @_;
387     printdebug "() $ourfn\n";
388     open PF, ">", $ourfn or die "$ourfn: $!";
389     for (;;) {
390         my ($y,$l) = protocol_expect {
391             m/^data-block (.*)$/ ? (1,$1) :
392             m/^data-end$/ ? (0,) :
393             ();
394         } $fh;
395         last unless $y;
396         my $d = protocol_read_bytes $fh, $l;
397         print PF $d or die $!;
398     }
399     close PF or die $!;
400 }
401
402 #---------- remote protocol support, responder ----------
403
404 sub responder_send_command ($) {
405     my ($command) = @_;
406     return unless $we_are_responder;
407     # called even without $we_are_responder
408     printdebug ">> $command\n";
409     print PO $command, "\n" or die $!;
410 }    
411
412 sub responder_send_file ($$) {
413     my ($keyword, $ourfn) = @_;
414     return unless $we_are_responder;
415     printdebug "]] $keyword $ourfn\n";
416     responder_send_command "file $keyword";
417     protocol_send_file \*PO, $ourfn;
418 }
419
420 sub responder_receive_files ($@) {
421     my ($keyword, @ourfns) = @_;
422     die unless $we_are_responder;
423     printdebug "[[ $keyword @ourfns\n";
424     responder_send_command "want $keyword";
425     foreach my $fn (@ourfns) {
426         protocol_receive_file \*PI, $fn;
427     }
428     printdebug "[[\$\n";
429     protocol_expect { m/^files-end$/ } \*PI;
430 }
431
432 #---------- remote protocol support, initiator ----------
433
434 sub initiator_expect (&) {
435     my ($match) = @_;
436     protocol_expect { &$match } \*RO;
437 }
438
439 #---------- end remote code ----------
440
441 sub progress {
442     if ($we_are_responder) {
443         my $m = join '', @_;
444         responder_send_command "progress ".length($m) or die $!;
445         print PO $m or die $!;
446     } else {
447         print @_, "\n";
448     }
449 }
450
451 our $ua;
452
453 sub url_get {
454     if (!$ua) {
455         $ua = LWP::UserAgent->new();
456         $ua->env_proxy;
457     }
458     my $what = $_[$#_];
459     progress "downloading $what...";
460     my $r = $ua->get(@_) or die $!;
461     return undef if $r->code == 404;
462     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
463     return $r->decoded_content(charset => 'none');
464 }
465
466 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
467
468 sub runcmd {
469     debugcmd "+",@_;
470     $!=0; $?=-1;
471     failedcmd @_ if system @_;
472 }
473
474 sub act_local () { return $dryrun_level <= 1; }
475 sub act_scary () { return !$dryrun_level; }
476
477 sub printdone {
478     if (!$dryrun_level) {
479         progress "dgit ok: @_";
480     } else {
481         progress "would be ok: @_ (but dry run only)";
482     }
483 }
484
485 sub dryrun_report {
486     printcmd(\*STDERR,$debugprefix."#",@_);
487 }
488
489 sub runcmd_ordryrun {
490     if (act_scary()) {
491         runcmd @_;
492     } else {
493         dryrun_report @_;
494     }
495 }
496
497 sub runcmd_ordryrun_local {
498     if (act_local()) {
499         runcmd @_;
500     } else {
501         dryrun_report @_;
502     }
503 }
504
505 sub shell_cmd {
506     my ($first_shell, @cmd) = @_;
507     return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
508 }
509
510 our $helpmsg = <<END;
511 main usages:
512   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
513   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
514   dgit [dgit-opts] build [dpkg-buildpackage-opts]
515   dgit [dgit-opts] sbuild [sbuild-opts]
516   dgit [dgit-opts] push [dgit-opts] [suite]
517   dgit [dgit-opts] rpush build-host:build-dir ...
518 important dgit options:
519   -k<keyid>           sign tag and package with <keyid> instead of default
520   --dry-run -n        do not change anything, but go through the motions
521   --damp-run -L       like --dry-run but make local changes, without signing
522   --new -N            allow introducing a new package
523   --debug -D          increase debug level
524   -c<name>=<value>    set git config option (used directly by dgit too)
525 END
526
527 our $later_warning_msg = <<END;
528 Perhaps the upload is stuck in incoming.  Using the version from git.
529 END
530
531 sub badusage {
532     print STDERR "$us: @_\n", $helpmsg or die $!;
533     exit 8;
534 }
535
536 sub nextarg {
537     @ARGV or badusage "too few arguments";
538     return scalar shift @ARGV;
539 }
540
541 sub cmd_help () {
542     print $helpmsg or die $!;
543     exit 0;
544 }
545
546 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
547
548 our %defcfg = ('dgit.default.distro' => 'debian',
549                'dgit.default.username' => '',
550                'dgit.default.archive-query-default-component' => 'main',
551                'dgit.default.ssh' => 'ssh',
552                'dgit.default.archive-query' => 'madison:',
553                'dgit.default.sshpsql-dbname' => 'service=projectb',
554                'dgit.default.dgit-tag-format' => 'old,new,maint',
555                # old means "repo server accepts pushes with old dgit tags"
556                # new means "repo server accepts pushes with new dgit tags"
557                # maint means "repo server accepts split brain pushes"
558                # hist means "repo server may have old pushes without new tag"
559                #   ("hist" is implied by "old")
560                'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
561                'dgit-distro.debian.git-check' => 'url',
562                'dgit-distro.debian.git-check-suffix' => '/info/refs',
563                'dgit-distro.debian.new-private-pushers' => 't',
564                'dgit-distro.debian.dgit-tag-format' => 'new',
565                'dgit-distro.debian/push.git-url' => '',
566                'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
567                'dgit-distro.debian/push.git-user-force' => 'dgit',
568                'dgit-distro.debian/push.git-proto' => 'git+ssh://',
569                'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
570                'dgit-distro.debian/push.git-create' => 'true',
571                'dgit-distro.debian/push.git-check' => 'ssh-cmd',
572  'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
573 # 'dgit-distro.debian.archive-query-tls-key',
574 #    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
575 # ^ this does not work because curl is broken nowadays
576 # Fixing #790093 properly will involve providing providing the key
577 # in some pacagke and maybe updating these paths.
578 #
579 # 'dgit-distro.debian.archive-query-tls-curl-args',
580 #   '--ca-path=/etc/ssl/ca-debian',
581 # ^ this is a workaround but works (only) on DSA-administered machines
582                'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
583                'dgit-distro.debian.git-url-suffix' => '',
584                'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
585                'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
586  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
587  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
588                'dgit-distro.ubuntu.git-check' => 'false',
589  'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
590                'dgit-distro.test-dummy.ssh' => "$td/ssh",
591                'dgit-distro.test-dummy.username' => "alice",
592                'dgit-distro.test-dummy.git-check' => "ssh-cmd",
593                'dgit-distro.test-dummy.git-create' => "ssh-cmd",
594                'dgit-distro.test-dummy.git-url' => "$td/git",
595                'dgit-distro.test-dummy.git-host' => "git",
596                'dgit-distro.test-dummy.git-path' => "$td/git",
597                'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
598                'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
599                'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
600                'dgit-distro.test-dummy.upload-host' => 'test-dummy',
601                );
602
603 our %gitcfgs;
604 our @gitcfgsources = qw(cmdline local global system);
605
606 sub git_slurp_config () {
607     local ($debuglevel) = $debuglevel-2;
608     local $/="\0";
609
610     # This algoritm is a bit subtle, but this is needed so that for
611     # options which we want to be single-valued, we allow the
612     # different config sources to override properly.  See #835858.
613     foreach my $src (@gitcfgsources) {
614         next if $src eq 'cmdline';
615         # we do this ourselves since git doesn't handle it
616         
617         my @cmd = (@git, qw(config -z --get-regexp), "--$src", qw(.*));
618         debugcmd "|",@cmd;
619
620         open GITS, "-|", @cmd or die $!;
621         while (<GITS>) {
622             chomp or die;
623             printdebug "=> ", (messagequote $_), "\n";
624             m/\n/ or die "$_ ?";
625             push @{ $gitcfgs{$src}{$`} }, $'; #';
626         }
627         $!=0; $?=0;
628         close GITS
629             or ($!==0 && $?==256)
630             or failedcmd @cmd;
631     }
632 }
633
634 sub git_get_config ($) {
635     my ($c) = @_;
636     foreach my $src (@gitcfgsources) {
637         my $l = $gitcfgs{$src}{$c};
638         printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
639             if $debuglevel >= 4;
640         $l or next;
641         @$l==1 or badcfg "multiple values for $c".
642             " (in $src git config)" if @$l > 1;
643         return $l->[0];
644     }
645     return undef;
646 }
647
648 sub cfg {
649     foreach my $c (@_) {
650         return undef if $c =~ /RETURN-UNDEF/;
651         my $v = git_get_config($c);
652         return $v if defined $v;
653         my $dv = $defcfg{$c};
654         return $dv if defined $dv;
655     }
656     badcfg "need value for one of: @_\n".
657         "$us: distro or suite appears not to be (properly) supported";
658 }
659
660 sub access_basedistro () {
661     if (defined $idistro) {
662         return $idistro;
663     } else {    
664         return cfg("dgit-suite.$isuite.distro",
665                    "dgit.default.distro");
666     }
667 }
668
669 sub access_quirk () {
670     # returns (quirk name, distro to use instead or undef, quirk-specific info)
671     my $basedistro = access_basedistro();
672     my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
673                               'RETURN-UNDEF');
674     if (defined $backports_quirk) {
675         my $re = $backports_quirk;
676         $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
677         $re =~ s/\*/.*/g;
678         $re =~ s/\%/([-0-9a-z_]+)/
679             or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
680         if ($isuite =~ m/^$re$/) {
681             return ('backports',"$basedistro-backports",$1);
682         }
683     }
684     return ('none',undef);
685 }
686
687 our $access_forpush;
688
689 sub parse_cfg_bool ($$$) {
690     my ($what,$def,$v) = @_;
691     $v //= $def;
692     return
693         $v =~ m/^[ty1]/ ? 1 :
694         $v =~ m/^[fn0]/ ? 0 :
695         badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
696 }       
697
698 sub access_forpush_config () {
699     my $d = access_basedistro();
700
701     return 1 if
702         $new_package &&
703         parse_cfg_bool('new-private-pushers', 0,
704                        cfg("dgit-distro.$d.new-private-pushers",
705                            'RETURN-UNDEF'));
706
707     my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
708     $v //= 'a';
709     return
710         $v =~ m/^[ty1]/ ? 0 : # force readonly,    forpush = 0
711         $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
712         $v =~ m/^[a]/  ? '' : # auto,              forpush = ''
713         badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
714 }
715
716 sub access_forpush () {
717     $access_forpush //= access_forpush_config();
718     return $access_forpush;
719 }
720
721 sub pushing () {
722     die "$access_forpush ?" if ($access_forpush // 1) ne 1;
723     badcfg "pushing but distro is configured readonly"
724         if access_forpush_config() eq '0';
725     $access_forpush = 1;
726     $supplementary_message = <<'END' unless $we_are_responder;
727 Push failed, before we got started.
728 You can retry the push, after fixing the problem, if you like.
729 END
730     finalise_opts_opts();
731 }
732
733 sub notpushing () {
734     finalise_opts_opts();
735 }
736
737 sub supplementary_message ($) {
738     my ($msg) = @_;
739     if (!$we_are_responder) {
740         $supplementary_message = $msg;
741         return;
742     } elsif ($protovsn >= 3) {
743         responder_send_command "supplementary-message ".length($msg)
744             or die $!;
745         print PO $msg or die $!;
746     }
747 }
748
749 sub access_distros () {
750     # Returns list of distros to try, in order
751     #
752     # We want to try:
753     #    0. `instead of' distro name(s) we have been pointed to
754     #    1. the access_quirk distro, if any
755     #    2a. the user's specified distro, or failing that  } basedistro
756     #    2b. the distro calculated from the suite          }
757     my @l = access_basedistro();
758
759     my (undef,$quirkdistro) = access_quirk();
760     unshift @l, $quirkdistro;
761     unshift @l, $instead_distro;
762     @l = grep { defined } @l;
763
764     if (access_forpush()) {
765         @l = map { ("$_/push", $_) } @l;
766     }
767     @l;
768 }
769
770 sub access_cfg_cfgs (@) {
771     my (@keys) = @_;
772     my @cfgs;
773     # The nesting of these loops determines the search order.  We put
774     # the key loop on the outside so that we search all the distros
775     # for each key, before going on to the next key.  That means that
776     # if access_cfg is called with a more specific, and then a less
777     # specific, key, an earlier distro can override the less specific
778     # without necessarily overriding any more specific keys.  (If the
779     # distro wants to override the more specific keys it can simply do
780     # so; whereas if we did the loop the other way around, it would be
781     # impossible to for an earlier distro to override a less specific
782     # key but not the more specific ones without restating the unknown
783     # values of the more specific keys.
784     my @realkeys;
785     my @rundef;
786     # We have to deal with RETURN-UNDEF specially, so that we don't
787     # terminate the search prematurely.
788     foreach (@keys) {
789         if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
790         push @realkeys, $_
791     }
792     foreach my $d (access_distros()) {
793         push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
794     }
795     push @cfgs, map { "dgit.default.$_" } @realkeys;
796     push @cfgs, @rundef;
797     return @cfgs;
798 }
799
800 sub access_cfg (@) {
801     my (@keys) = @_;
802     my (@cfgs) = access_cfg_cfgs(@keys);
803     my $value = cfg(@cfgs);
804     return $value;
805 }
806
807 sub access_cfg_bool ($$) {
808     my ($def, @keys) = @_;
809     parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
810 }
811
812 sub string_to_ssh ($) {
813     my ($spec) = @_;
814     if ($spec =~ m/\s/) {
815         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
816     } else {
817         return ($spec);
818     }
819 }
820
821 sub access_cfg_ssh () {
822     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
823     if (!defined $gitssh) {
824         return @ssh;
825     } else {
826         return string_to_ssh $gitssh;
827     }
828 }
829
830 sub access_runeinfo ($) {
831     my ($info) = @_;
832     return ": dgit ".access_basedistro()." $info ;";
833 }
834
835 sub access_someuserhost ($) {
836     my ($some) = @_;
837     my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
838     defined($user) && length($user) or
839         $user = access_cfg("$some-user",'username');
840     my $host = access_cfg("$some-host");
841     return length($user) ? "$user\@$host" : $host;
842 }
843
844 sub access_gituserhost () {
845     return access_someuserhost('git');
846 }
847
848 sub access_giturl (;$) {
849     my ($optional) = @_;
850     my $url = access_cfg('git-url','RETURN-UNDEF');
851     my $suffix;
852     if (!length $url) {
853         my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
854         return undef unless defined $proto;
855         $url =
856             $proto.
857             access_gituserhost().
858             access_cfg('git-path');
859     } else {
860         $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
861     }
862     $suffix //= '.git';
863     return "$url/$package$suffix";
864 }              
865
866 sub parsecontrolfh ($$;$) {
867     my ($fh, $desc, $allowsigned) = @_;
868     our $dpkgcontrolhash_noissigned;
869     my $c;
870     for (;;) {
871         my %opts = ('name' => $desc);
872         $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
873         $c = Dpkg::Control::Hash->new(%opts);
874         $c->parse($fh,$desc) or die "parsing of $desc failed";
875         last if $allowsigned;
876         last if $dpkgcontrolhash_noissigned;
877         my $issigned= $c->get_option('is_pgp_signed');
878         if (!defined $issigned) {
879             $dpkgcontrolhash_noissigned= 1;
880             seek $fh, 0,0 or die "seek $desc: $!";
881         } elsif ($issigned) {
882             fail "control file $desc is (already) PGP-signed. ".
883                 " Note that dgit push needs to modify the .dsc and then".
884                 " do the signature itself";
885         } else {
886             last;
887         }
888     }
889     return $c;
890 }
891
892 sub parsecontrol {
893     my ($file, $desc) = @_;
894     my $fh = new IO::Handle;
895     open $fh, '<', $file or die "$file: $!";
896     my $c = parsecontrolfh($fh,$desc);
897     $fh->error and die $!;
898     close $fh;
899     return $c;
900 }
901
902 sub getfield ($$) {
903     my ($dctrl,$field) = @_;
904     my $v = $dctrl->{$field};
905     return $v if defined $v;
906     fail "missing field $field in ".$dctrl->get_option('name');
907 }
908
909 sub parsechangelog {
910     my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
911     my $p = new IO::Handle;
912     my @cmd = (qw(dpkg-parsechangelog), @_);
913     open $p, '-|', @cmd or die $!;
914     $c->parse($p);
915     $?=0; $!=0; close $p or failedcmd @cmd;
916     return $c;
917 }
918
919 sub commit_getclogp ($) {
920     # Returns the parsed changelog hashref for a particular commit
921     my ($objid) = @_;
922     our %commit_getclogp_memo;
923     my $memo = $commit_getclogp_memo{$objid};
924     return $memo if $memo;
925     mkpath '.git/dgit';
926     my $mclog = ".git/dgit/clog-$objid";
927     runcmd shell_cmd "exec >$mclog", @git, qw(cat-file blob),
928         "$objid:debian/changelog";
929     $commit_getclogp_memo{$objid} = parsechangelog("-l$mclog");
930 }
931
932 sub must_getcwd () {
933     my $d = getcwd();
934     defined $d or fail "getcwd failed: $!";
935     return $d;
936 }
937
938 our %rmad;
939
940 sub archive_query ($) {
941     my ($method) = @_;
942     my $query = access_cfg('archive-query','RETURN-UNDEF');
943     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
944     my $proto = $1;
945     my $data = $'; #';
946     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
947 }
948
949 sub pool_dsc_subpath ($$) {
950     my ($vsn,$component) = @_; # $package is implict arg
951     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
952     return "/pool/$component/$prefix/$package/".dscfn($vsn);
953 }
954
955 #---------- `ftpmasterapi' archive query method (nascent) ----------
956
957 sub archive_api_query_cmd ($) {
958     my ($subpath) = @_;
959     my @cmd = qw(curl -sS);
960     my $url = access_cfg('archive-query-url');
961     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
962         my $host = $1;
963         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
964         foreach my $key (split /\:/, $keys) {
965             $key =~ s/\%HOST\%/$host/g;
966             if (!stat $key) {
967                 fail "for $url: stat $key: $!" unless $!==ENOENT;
968                 next;
969             }
970             fail "config requested specific TLS key but do not know".
971                 " how to get curl to use exactly that EE key ($key)";
972 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
973 #           # Sadly the above line does not work because of changes
974 #           # to gnutls.   The real fix for #790093 may involve
975 #           # new curl options.
976             last;
977         }
978         # Fixing #790093 properly will involve providing a value
979         # for this on clients.
980         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
981         push @cmd, split / /, $kargs if defined $kargs;
982     }
983     push @cmd, $url.$subpath;
984     return @cmd;
985 }
986
987 sub api_query ($$) {
988     use JSON;
989     my ($data, $subpath) = @_;
990     badcfg "ftpmasterapi archive query method takes no data part"
991         if length $data;
992     my @cmd = archive_api_query_cmd($subpath);
993     my $json = cmdoutput @cmd;
994     return decode_json($json);
995 }
996
997 sub canonicalise_suite_ftpmasterapi () {
998     my ($proto,$data) = @_;
999     my $suites = api_query($data, 'suites');
1000     my @matched;
1001     foreach my $entry (@$suites) {
1002         next unless grep { 
1003             my $v = $entry->{$_};
1004             defined $v && $v eq $isuite;
1005         } qw(codename name);
1006         push @matched, $entry;
1007     }
1008     fail "unknown suite $isuite" unless @matched;
1009     my $cn;
1010     eval {
1011         @matched==1 or die "multiple matches for suite $isuite\n";
1012         $cn = "$matched[0]{codename}";
1013         defined $cn or die "suite $isuite info has no codename\n";
1014         $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1015     };
1016     die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1017         if length $@;
1018     return $cn;
1019 }
1020
1021 sub archive_query_ftpmasterapi () {
1022     my ($proto,$data) = @_;
1023     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1024     my @rows;
1025     my $digester = Digest::SHA->new(256);
1026     foreach my $entry (@$info) {
1027         eval {
1028             my $vsn = "$entry->{version}";
1029             my ($ok,$msg) = version_check $vsn;
1030             die "bad version: $msg\n" unless $ok;
1031             my $component = "$entry->{component}";
1032             $component =~ m/^$component_re$/ or die "bad component";
1033             my $filename = "$entry->{filename}";
1034             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1035                 or die "bad filename";
1036             my $sha256sum = "$entry->{sha256sum}";
1037             $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1038             push @rows, [ $vsn, "/pool/$component/$filename",
1039                           $digester, $sha256sum ];
1040         };
1041         die "bad ftpmaster api response: $@\n".Dumper($entry)
1042             if length $@;
1043     }
1044     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1045     return @rows;
1046 }
1047
1048 #---------- `madison' archive query method ----------
1049
1050 sub archive_query_madison {
1051     return map { [ @$_[0..1] ] } madison_get_parse(@_);
1052 }
1053
1054 sub madison_get_parse {
1055     my ($proto,$data) = @_;
1056     die unless $proto eq 'madison';
1057     if (!length $data) {
1058         $data= access_cfg('madison-distro','RETURN-UNDEF');
1059         $data //= access_basedistro();
1060     }
1061     $rmad{$proto,$data,$package} ||= cmdoutput
1062         qw(rmadison -asource),"-s$isuite","-u$data",$package;
1063     my $rmad = $rmad{$proto,$data,$package};
1064
1065     my @out;
1066     foreach my $l (split /\n/, $rmad) {
1067         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1068                   \s*( [^ \t|]+ )\s* \|
1069                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1070                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1071         $1 eq $package or die "$rmad $package ?";
1072         my $vsn = $2;
1073         my $newsuite = $3;
1074         my $component;
1075         if (defined $4) {
1076             $component = $4;
1077         } else {
1078             $component = access_cfg('archive-query-default-component');
1079         }
1080         $5 eq 'source' or die "$rmad ?";
1081         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1082     }
1083     return sort { -version_compare($a->[0],$b->[0]); } @out;
1084 }
1085
1086 sub canonicalise_suite_madison {
1087     # madison canonicalises for us
1088     my @r = madison_get_parse(@_);
1089     @r or fail
1090         "unable to canonicalise suite using package $package".
1091         " which does not appear to exist in suite $isuite;".
1092         " --existing-package may help";
1093     return $r[0][2];
1094 }
1095
1096 #---------- `sshpsql' archive query method ----------
1097
1098 sub sshpsql ($$$) {
1099     my ($data,$runeinfo,$sql) = @_;
1100     if (!length $data) {
1101         $data= access_someuserhost('sshpsql').':'.
1102             access_cfg('sshpsql-dbname');
1103     }
1104     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1105     my ($userhost,$dbname) = ($`,$'); #';
1106     my @rows;
1107     my @cmd = (access_cfg_ssh, $userhost,
1108                access_runeinfo("ssh-psql $runeinfo").
1109                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1110                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1111     debugcmd "|",@cmd;
1112     open P, "-|", @cmd or die $!;
1113     while (<P>) {
1114         chomp or die;
1115         printdebug(">|$_|\n");
1116         push @rows, $_;
1117     }
1118     $!=0; $?=0; close P or failedcmd @cmd;
1119     @rows or die;
1120     my $nrows = pop @rows;
1121     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1122     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1123     @rows = map { [ split /\|/, $_ ] } @rows;
1124     my $ncols = scalar @{ shift @rows };
1125     die if grep { scalar @$_ != $ncols } @rows;
1126     return @rows;
1127 }
1128
1129 sub sql_injection_check {
1130     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1131 }
1132
1133 sub archive_query_sshpsql ($$) {
1134     my ($proto,$data) = @_;
1135     sql_injection_check $isuite, $package;
1136     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1137         SELECT source.version, component.name, files.filename, files.sha256sum
1138           FROM source
1139           JOIN src_associations ON source.id = src_associations.source
1140           JOIN suite ON suite.id = src_associations.suite
1141           JOIN dsc_files ON dsc_files.source = source.id
1142           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1143           JOIN component ON component.id = files_archive_map.component_id
1144           JOIN files ON files.id = dsc_files.file
1145          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1146            AND source.source='$package'
1147            AND files.filename LIKE '%.dsc';
1148 END
1149     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1150     my $digester = Digest::SHA->new(256);
1151     @rows = map {
1152         my ($vsn,$component,$filename,$sha256sum) = @$_;
1153         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1154     } @rows;
1155     return @rows;
1156 }
1157
1158 sub canonicalise_suite_sshpsql ($$) {
1159     my ($proto,$data) = @_;
1160     sql_injection_check $isuite;
1161     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1162         SELECT suite.codename
1163           FROM suite where suite_name='$isuite' or codename='$isuite';
1164 END
1165     @rows = map { $_->[0] } @rows;
1166     fail "unknown suite $isuite" unless @rows;
1167     die "ambiguous $isuite: @rows ?" if @rows>1;
1168     return $rows[0];
1169 }
1170
1171 #---------- `dummycat' archive query method ----------
1172
1173 sub canonicalise_suite_dummycat ($$) {
1174     my ($proto,$data) = @_;
1175     my $dpath = "$data/suite.$isuite";
1176     if (!open C, "<", $dpath) {
1177         $!==ENOENT or die "$dpath: $!";
1178         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1179         return $isuite;
1180     }
1181     $!=0; $_ = <C>;
1182     chomp or die "$dpath: $!";
1183     close C;
1184     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1185     return $_;
1186 }
1187
1188 sub archive_query_dummycat ($$) {
1189     my ($proto,$data) = @_;
1190     canonicalise_suite();
1191     my $dpath = "$data/package.$csuite.$package";
1192     if (!open C, "<", $dpath) {
1193         $!==ENOENT or die "$dpath: $!";
1194         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1195         return ();
1196     }
1197     my @rows;
1198     while (<C>) {
1199         next if m/^\#/;
1200         next unless m/\S/;
1201         die unless chomp;
1202         printdebug "dummycat query $csuite $package $dpath | $_\n";
1203         my @row = split /\s+/, $_;
1204         @row==2 or die "$dpath: $_ ?";
1205         push @rows, \@row;
1206     }
1207     C->error and die "$dpath: $!";
1208     close C;
1209     return sort { -version_compare($a->[0],$b->[0]); } @rows;
1210 }
1211
1212 #---------- tag format handling ----------
1213
1214 sub access_cfg_tagformats () {
1215     split /\,/, access_cfg('dgit-tag-format');
1216 }
1217
1218 sub need_tagformat ($$) {
1219     my ($fmt, $why) = @_;
1220     fail "need to use tag format $fmt ($why) but also need".
1221         " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1222         " - no way to proceed"
1223         if $tagformat_want && $tagformat_want->[0] ne $fmt;
1224     $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1225 }
1226
1227 sub select_tagformat () {
1228     # sets $tagformatfn
1229     return if $tagformatfn && !$tagformat_want;
1230     die 'bug' if $tagformatfn && $tagformat_want;
1231     # ... $tagformat_want assigned after previous select_tagformat
1232
1233     my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1234     printdebug "select_tagformat supported @supported\n";
1235
1236     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1237     printdebug "select_tagformat specified @$tagformat_want\n";
1238
1239     my ($fmt,$why,$override) = @$tagformat_want;
1240
1241     fail "target distro supports tag formats @supported".
1242         " but have to use $fmt ($why)"
1243         unless $override
1244             or grep { $_ eq $fmt } @supported;
1245
1246     $tagformat_want = undef;
1247     $tagformat = $fmt;
1248     $tagformatfn = ${*::}{"debiantag_$fmt"};
1249
1250     fail "trying to use unknown tag format \`$fmt' ($why) !"
1251         unless $tagformatfn;
1252 }
1253
1254 #---------- archive query entrypoints and rest of program ----------
1255
1256 sub canonicalise_suite () {
1257     return if defined $csuite;
1258     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1259     $csuite = archive_query('canonicalise_suite');
1260     if ($isuite ne $csuite) {
1261         progress "canonical suite name for $isuite is $csuite";
1262     }
1263 }
1264
1265 sub get_archive_dsc () {
1266     canonicalise_suite();
1267     my @vsns = archive_query('archive_query');
1268     foreach my $vinfo (@vsns) {
1269         my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1270         $dscurl = access_cfg('mirror').$subpath;
1271         $dscdata = url_get($dscurl);
1272         if (!$dscdata) {
1273             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1274             next;
1275         }
1276         if ($digester) {
1277             $digester->reset();
1278             $digester->add($dscdata);
1279             my $got = $digester->hexdigest();
1280             $got eq $digest or
1281                 fail "$dscurl has hash $got but".
1282                     " archive told us to expect $digest";
1283         }
1284         my $dscfh = new IO::File \$dscdata, '<' or die $!;
1285         printdebug Dumper($dscdata) if $debuglevel>1;
1286         $dsc = parsecontrolfh($dscfh,$dscurl,1);
1287         printdebug Dumper($dsc) if $debuglevel>1;
1288         my $fmt = getfield $dsc, 'Format';
1289         fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1290         $dsc_checked = !!$digester;
1291         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1292         return;
1293     }
1294     $dsc = undef;
1295     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1296 }
1297
1298 sub check_for_git ();
1299 sub check_for_git () {
1300     # returns 0 or 1
1301     my $how = access_cfg('git-check');
1302     if ($how eq 'ssh-cmd') {
1303         my @cmd =
1304             (access_cfg_ssh, access_gituserhost(),
1305              access_runeinfo("git-check $package").
1306              " set -e; cd ".access_cfg('git-path').";".
1307              " if test -d $package.git; then echo 1; else echo 0; fi");
1308         my $r= cmdoutput @cmd;
1309         if (defined $r and $r =~ m/^divert (\w+)$/) {
1310             my $divert=$1;
1311             my ($usedistro,) = access_distros();
1312             # NB that if we are pushing, $usedistro will be $distro/push
1313             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1314             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1315             progress "diverting to $divert (using config for $instead_distro)";
1316             return check_for_git();
1317         }
1318         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1319         return $r+0;
1320     } elsif ($how eq 'url') {
1321         my $prefix = access_cfg('git-check-url','git-url');
1322         my $suffix = access_cfg('git-check-suffix','git-suffix',
1323                                 'RETURN-UNDEF') // '.git';
1324         my $url = "$prefix/$package$suffix";
1325         my @cmd = (qw(curl -sS -I), $url);
1326         my $result = cmdoutput @cmd;
1327         $result =~ s/^\S+ 200 .*\n\r?\n//;
1328         # curl -sS -I with https_proxy prints
1329         # HTTP/1.0 200 Connection established
1330         $result =~ m/^\S+ (404|200) /s or
1331             fail "unexpected results from git check query - ".
1332                 Dumper($prefix, $result);
1333         my $code = $1;
1334         if ($code eq '404') {
1335             return 0;
1336         } elsif ($code eq '200') {
1337             return 1;
1338         } else {
1339             die;
1340         }
1341     } elsif ($how eq 'true') {
1342         return 1;
1343     } elsif ($how eq 'false') {
1344         return 0;
1345     } else {
1346         badcfg "unknown git-check \`$how'";
1347     }
1348 }
1349
1350 sub create_remote_git_repo () {
1351     my $how = access_cfg('git-create');
1352     if ($how eq 'ssh-cmd') {
1353         runcmd_ordryrun
1354             (access_cfg_ssh, access_gituserhost(),
1355              access_runeinfo("git-create $package").
1356              "set -e; cd ".access_cfg('git-path').";".
1357              " cp -a _template $package.git");
1358     } elsif ($how eq 'true') {
1359         # nothing to do
1360     } else {
1361         badcfg "unknown git-create \`$how'";
1362     }
1363 }
1364
1365 our ($dsc_hash,$lastpush_mergeinput);
1366
1367 our $ud = '.git/dgit/unpack';
1368
1369 sub prep_ud (;$) {
1370     my ($d) = @_;
1371     $d //= $ud;
1372     rmtree($d);
1373     mkpath '.git/dgit';
1374     mkdir $d or die $!;
1375 }
1376
1377 sub mktree_in_ud_here () {
1378     runcmd qw(git init -q);
1379     runcmd qw(git config gc.auto 0);
1380     rmtree('.git/objects');
1381     symlink '../../../../objects','.git/objects' or die $!;
1382 }
1383
1384 sub git_write_tree () {
1385     my $tree = cmdoutput @git, qw(write-tree);
1386     $tree =~ m/^\w+$/ or die "$tree ?";
1387     return $tree;
1388 }
1389
1390 sub remove_stray_gits () {
1391     my @gitscmd = qw(find -name .git -prune -print0);
1392     debugcmd "|",@gitscmd;
1393     open GITS, "-|", @gitscmd or die $!;
1394     {
1395         local $/="\0";
1396         while (<GITS>) {
1397             chomp or die;
1398             print STDERR "$us: warning: removing from source package: ",
1399                 (messagequote $_), "\n";
1400             rmtree $_;
1401         }
1402     }
1403     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1404 }
1405
1406 sub mktree_in_ud_from_only_subdir (;$) {
1407     my ($raw) = @_;
1408
1409     # changes into the subdir
1410     my (@dirs) = <*/.>;
1411     die "expected one subdir but found @dirs ?" unless @dirs==1;
1412     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1413     my $dir = $1;
1414     changedir $dir;
1415
1416     remove_stray_gits();
1417     mktree_in_ud_here();
1418     if (!$raw) {
1419         my ($format, $fopts) = get_source_format();
1420         if (madformat($format)) {
1421             rmtree '.pc';
1422         }
1423     }
1424
1425     runcmd @git, qw(add -Af);
1426     my $tree=git_write_tree();
1427     return ($tree,$dir);
1428 }
1429
1430 our @files_csum_info_fields = 
1431     (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1432      ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1433      ['Files',           'Digest::MD5', 'new()']);
1434
1435 sub dsc_files_info () {
1436     foreach my $csumi (@files_csum_info_fields) {
1437         my ($fname, $module, $method) = @$csumi;
1438         my $field = $dsc->{$fname};
1439         next unless defined $field;
1440         eval "use $module; 1;" or die $@;
1441         my @out;
1442         foreach (split /\n/, $field) {
1443             next unless m/\S/;
1444             m/^(\w+) (\d+) (\S+)$/ or
1445                 fail "could not parse .dsc $fname line \`$_'";
1446             my $digester = eval "$module"."->$method;" or die $@;
1447             push @out, {
1448                 Hash => $1,
1449                 Bytes => $2,
1450                 Filename => $3,
1451                 Digester => $digester,
1452             };
1453         }
1454         return @out;
1455     }
1456     fail "missing any supported Checksums-* or Files field in ".
1457         $dsc->get_option('name');
1458 }
1459
1460 sub dsc_files () {
1461     map { $_->{Filename} } dsc_files_info();
1462 }
1463
1464 sub files_compare_inputs (@) {
1465     my $inputs = \@_;
1466     my %record;
1467     my %fchecked;
1468
1469     my $showinputs = sub {
1470         return join "; ", map { $_->get_option('name') } @$inputs;
1471     };
1472
1473     foreach my $in (@$inputs) {
1474         my $expected_files;
1475         my $in_name = $in->get_option('name');
1476
1477         printdebug "files_compare_inputs $in_name\n";
1478
1479         foreach my $csumi (@files_csum_info_fields) {
1480             my ($fname) = @$csumi;
1481             printdebug "files_compare_inputs $in_name $fname\n";
1482
1483             my $field = $in->{$fname};
1484             next unless defined $field;
1485
1486             my @files;
1487             foreach (split /\n/, $field) {
1488                 next unless m/\S/;
1489
1490                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1491                     fail "could not parse $in_name $fname line \`$_'";
1492
1493                 printdebug "files_compare_inputs $in_name $fname $f\n";
1494
1495                 push @files, $f;
1496
1497                 my $re = \ $record{$f}{$fname};
1498                 if (defined $$re) {
1499                     $fchecked{$f}{$in_name} = 1;
1500                     $$re eq $info or
1501                         fail "hash or size of $f varies in $fname fields".
1502                         " (between: ".$showinputs->().")";
1503                 } else {
1504                     $$re = $info;
1505                 }
1506             }
1507             @files = sort @files;
1508             $expected_files //= \@files;
1509             "@$expected_files" eq "@files" or
1510                 fail "file list in $in_name varies between hash fields!";
1511         }
1512         $expected_files or
1513             fail "$in_name has no files list field(s)";
1514     }
1515     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1516         if $debuglevel>=2;
1517
1518     grep { keys %$_ == @$inputs-1 } values %fchecked
1519         or fail "no file appears in all file lists".
1520         " (looked in: ".$showinputs->().")";
1521 }
1522
1523 sub is_orig_file_in_dsc ($$) {
1524     my ($f, $dsc_files_info) = @_;
1525     return 0 if @$dsc_files_info <= 1;
1526     # One file means no origs, and the filename doesn't have a "what
1527     # part of dsc" component.  (Consider versions ending `.orig'.)
1528     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1529     return 1;
1530 }
1531
1532 sub is_orig_file_of_vsn ($$) {
1533     my ($f, $upstreamvsn) = @_;
1534     my $base = srcfn $upstreamvsn, '';
1535     return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1536     return 1;
1537 }
1538
1539 sub make_commit ($) {
1540     my ($file) = @_;
1541     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1542 }
1543
1544 sub make_commit_text ($) {
1545     my ($text) = @_;
1546     my ($out, $in);
1547     my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1548     debugcmd "|",@cmd;
1549     print Dumper($text) if $debuglevel > 1;
1550     my $child = open2($out, $in, @cmd) or die $!;
1551     my $h;
1552     eval {
1553         print $in $text or die $!;
1554         close $in or die $!;
1555         $h = <$out>;
1556         $h =~ m/^\w+$/ or die;
1557         $h = $&;
1558         printdebug "=> $h\n";
1559     };
1560     close $out;
1561     waitpid $child, 0 == $child or die "$child $!";
1562     $? and failedcmd @cmd;
1563     return $h;
1564 }
1565
1566 sub clogp_authline ($) {
1567     my ($clogp) = @_;
1568     my $author = getfield $clogp, 'Maintainer';
1569     $author =~ s#,.*##ms;
1570     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1571     my $authline = "$author $date";
1572     $authline =~ m/$git_authline_re/o or
1573         fail "unexpected commit author line format \`$authline'".
1574         " (was generated from changelog Maintainer field)";
1575     return ($1,$2,$3) if wantarray;
1576     return $authline;
1577 }
1578
1579 sub vendor_patches_distro ($$) {
1580     my ($checkdistro, $what) = @_;
1581     return unless defined $checkdistro;
1582
1583     my $series = "debian/patches/\L$checkdistro\E.series";
1584     printdebug "checking for vendor-specific $series ($what)\n";
1585
1586     if (!open SERIES, "<", $series) {
1587         die "$series $!" unless $!==ENOENT;
1588         return;
1589     }
1590     while (<SERIES>) {
1591         next unless m/\S/;
1592         next if m/^\s+\#/;
1593
1594         print STDERR <<END;
1595
1596 Unfortunately, this source package uses a feature of dpkg-source where
1597 the same source package unpacks to different source code on different
1598 distros.  dgit cannot safely operate on such packages on affected
1599 distros, because the meaning of source packages is not stable.
1600
1601 Please ask the distro/maintainer to remove the distro-specific series
1602 files and use a different technique (if necessary, uploading actually
1603 different packages, if different distros are supposed to have
1604 different code).
1605
1606 END
1607         fail "Found active distro-specific series file for".
1608             " $checkdistro ($what): $series, cannot continue";
1609     }
1610     die "$series $!" if SERIES->error;
1611     close SERIES;
1612 }
1613
1614 sub check_for_vendor_patches () {
1615     # This dpkg-source feature doesn't seem to be documented anywhere!
1616     # But it can be found in the changelog (reformatted):
1617
1618     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1619     #   Author: Raphael Hertzog <hertzog@debian.org>
1620     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1621
1622     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1623     #   series files
1624     #   
1625     #   If you have debian/patches/ubuntu.series and you were
1626     #   unpacking the source package on ubuntu, quilt was still
1627     #   directed to debian/patches/series instead of
1628     #   debian/patches/ubuntu.series.
1629     #   
1630     #   debian/changelog                        |    3 +++
1631     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1632     #   2 files changed, 6 insertions(+), 1 deletion(-)
1633
1634     use Dpkg::Vendor;
1635     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1636     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1637                          "Dpkg::Vendor \`current vendor'");
1638     vendor_patches_distro(access_basedistro(),
1639                           "distro being accessed");
1640 }
1641
1642 sub generate_commits_from_dsc () {
1643     # See big comment in fetch_from_archive, below.
1644     # See also README.dsc-import.
1645     prep_ud();
1646     changedir $ud;
1647
1648     my @dfi = dsc_files_info();
1649     foreach my $fi (@dfi) {
1650         my $f = $fi->{Filename};
1651         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1652
1653         link_ltarget "../../../$f", $f
1654             or $!==&ENOENT
1655             or die "$f $!";
1656
1657         complete_file_from_dsc('.', $fi)
1658             or next;
1659
1660         if (is_orig_file_in_dsc($f, \@dfi)) {
1661             link $f, "../../../../$f"
1662                 or $!==&EEXIST
1663                 or die "$f $!";
1664         }
1665     }
1666
1667     # We unpack and record the orig tarballs first, so that we only
1668     # need disk space for one private copy of the unpacked source.
1669     # But we can't make them into commits until we have the metadata
1670     # from the debian/changelog, so we record the tree objects now and
1671     # make them into commits later.
1672     my @tartrees;
1673     my $upstreamv = $dsc->{version};
1674     $upstreamv =~ s/-[^-]+$//;
1675     my $orig_f_base = srcfn $upstreamv, '';
1676
1677     foreach my $fi (@dfi) {
1678         # We actually import, and record as a commit, every tarball
1679         # (unless there is only one file, in which case there seems
1680         # little point.
1681
1682         my $f = $fi->{Filename};
1683         printdebug "import considering $f ";
1684         (printdebug "only one dfi\n"), next if @dfi == 1;
1685         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1686         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1687         my $compr_ext = $1;
1688
1689         my ($orig_f_part) =
1690             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1691
1692         printdebug "Y ", (join ' ', map { $_//"(none)" }
1693                           $compr_ext, $orig_f_part
1694                          ), "\n";
1695
1696         my $input = new IO::File $f, '<' or die "$f $!";
1697         my $compr_pid;
1698         my @compr_cmd;
1699
1700         if (defined $compr_ext) {
1701             my $cname =
1702                 Dpkg::Compression::compression_guess_from_filename $f;
1703             fail "Dpkg::Compression cannot handle file $f in source package"
1704                 if defined $compr_ext && !defined $cname;
1705             my $compr_proc =
1706                 new Dpkg::Compression::Process compression => $cname;
1707             my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1708             my $compr_fh = new IO::Handle;
1709             my $compr_pid = open $compr_fh, "-|" // die $!;
1710             if (!$compr_pid) {
1711                 open STDIN, "<&", $input or die $!;
1712                 exec @compr_cmd;
1713                 die "dgit (child): exec $compr_cmd[0]: $!\n";
1714             }
1715             $input = $compr_fh;
1716         }
1717
1718         rmtree "../unpack-tar";
1719         mkdir "../unpack-tar" or die $!;
1720         my @tarcmd = qw(tar -x -f -
1721                         --no-same-owner --no-same-permissions
1722                         --no-acls --no-xattrs --no-selinux);
1723         my $tar_pid = fork // die $!;
1724         if (!$tar_pid) {
1725             chdir "../unpack-tar" or die $!;
1726             open STDIN, "<&", $input or die $!;
1727             exec @tarcmd;
1728             die "dgit (child): exec $tarcmd[0]: $!";
1729         }
1730         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1731         !$? or failedcmd @tarcmd;
1732
1733         close $input or
1734             (@compr_cmd ? failedcmd @compr_cmd
1735              : die $!);
1736         # finally, we have the results in "tarball", but maybe
1737         # with the wrong permissions
1738
1739         runcmd qw(chmod -R +rwX ../unpack-tar);
1740         changedir "../unpack-tar";
1741         my ($tree) = mktree_in_ud_from_only_subdir(1);
1742         changedir "../../unpack";
1743         rmtree "../unpack-tar";
1744
1745         my $ent = [ $f, $tree ];
1746         push @tartrees, {
1747             Orig => !!$orig_f_part,
1748             Sort => (!$orig_f_part         ? 2 :
1749                      $orig_f_part =~ m/-/g ? 1 :
1750                                              0),
1751             F => $f,
1752             Tree => $tree,
1753         };
1754     }
1755
1756     @tartrees = sort {
1757         # put any without "_" first (spec is not clear whether files
1758         # are always in the usual order).  Tarballs without "_" are
1759         # the main orig or the debian tarball.
1760         $a->{Sort} <=> $b->{Sort} or
1761         $a->{F}    cmp $b->{F}
1762     } @tartrees;
1763
1764     my $any_orig = grep { $_->{Orig} } @tartrees;
1765
1766     my $dscfn = "$package.dsc";
1767
1768     my $treeimporthow = 'package';
1769
1770     open D, ">", $dscfn or die "$dscfn: $!";
1771     print D $dscdata or die "$dscfn: $!";
1772     close D or die "$dscfn: $!";
1773     my @cmd = qw(dpkg-source);
1774     push @cmd, '--no-check' if $dsc_checked;
1775     if (madformat $dsc->{format}) {
1776         push @cmd, '--skip-patches';
1777         $treeimporthow = 'unpatched';
1778     }
1779     push @cmd, qw(-x --), $dscfn;
1780     runcmd @cmd;
1781
1782     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1783     if (madformat $dsc->{format}) { 
1784         check_for_vendor_patches();
1785     }
1786
1787     my $dappliedtree;
1788     if (madformat $dsc->{format}) {
1789         my @pcmd = qw(dpkg-source --before-build .);
1790         runcmd shell_cmd 'exec >/dev/null', @pcmd;
1791         rmtree '.pc';
1792         runcmd @git, qw(add -Af);
1793         $dappliedtree = git_write_tree();
1794     }
1795
1796     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1797     debugcmd "|",@clogcmd;
1798     open CLOGS, "-|", @clogcmd or die $!;
1799
1800     my $clogp;
1801     my $r1clogp;
1802
1803     printdebug "import clog search...\n";
1804
1805     for (;;) {
1806         my $stanzatext = do { local $/=""; <CLOGS>; };
1807         printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1808         last if !defined $stanzatext;
1809
1810         my $desc = "package changelog, entry no.$.";
1811         open my $stanzafh, "<", \$stanzatext or die;
1812         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1813         $clogp //= $thisstanza;
1814
1815         printdebug "import clog $thisstanza->{version} $desc...\n";
1816
1817         last if !$any_orig; # we don't need $r1clogp
1818
1819         # We look for the first (most recent) changelog entry whose
1820         # version number is lower than the upstream version of this
1821         # package.  Then the last (least recent) previous changelog
1822         # entry is treated as the one which introduced this upstream
1823         # version and used for the synthetic commits for the upstream
1824         # tarballs.
1825
1826         # One might think that a more sophisticated algorithm would be
1827         # necessary.  But: we do not want to scan the whole changelog
1828         # file.  Stopping when we see an earlier version, which
1829         # necessarily then is an earlier upstream version, is the only
1830         # realistic way to do that.  Then, either the earliest
1831         # changelog entry we have seen so far is indeed the earliest
1832         # upload of this upstream version; or there are only changelog
1833         # entries relating to later upstream versions (which is not
1834         # possible unless the changelog and .dsc disagree about the
1835         # version).  Then it remains to choose between the physically
1836         # last entry in the file, and the one with the lowest version
1837         # number.  If these are not the same, we guess that the
1838         # versions were created in a non-monotic order rather than
1839         # that the changelog entries have been misordered.
1840
1841         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
1842
1843         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
1844         $r1clogp = $thisstanza;
1845
1846         printdebug "import clog $r1clogp->{version} becomes r1\n";
1847     }
1848     die $! if CLOGS->error;
1849     close CLOGS or $?==(SIGPIPE<<8) or failedcmd @clogcmd;
1850
1851     $clogp or fail "package changelog has no entries!";
1852
1853     my $authline = clogp_authline $clogp;
1854     my $changes = getfield $clogp, 'Changes';
1855     my $cversion = getfield $clogp, 'Version';
1856
1857     if (@tartrees) {
1858         $r1clogp //= $clogp; # maybe there's only one entry;
1859         my $r1authline = clogp_authline $r1clogp;
1860         # Strictly, r1authline might now be wrong if it's going to be
1861         # unused because !$any_orig.  Whatever.
1862
1863         printdebug "import tartrees authline   $authline\n";
1864         printdebug "import tartrees r1authline $r1authline\n";
1865
1866         foreach my $tt (@tartrees) {
1867             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
1868
1869             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
1870 tree $tt->{Tree}
1871 author $r1authline
1872 committer $r1authline
1873
1874 Import $tt->{F}
1875
1876 [dgit import orig $tt->{F}]
1877 END_O
1878 tree $tt->{Tree}
1879 author $authline
1880 committer $authline
1881
1882 Import $tt->{F}
1883
1884 [dgit import tarball $package $cversion $tt->{F}]
1885 END_T
1886         }
1887     }
1888
1889     printdebug "import main commit\n";
1890
1891     open C, ">../commit.tmp" or die $!;
1892     print C <<END or die $!;
1893 tree $tree
1894 END
1895     print C <<END or die $! foreach @tartrees;
1896 parent $_->{Commit}
1897 END
1898     print C <<END or die $!;
1899 author $authline
1900 committer $authline
1901
1902 $changes
1903
1904 [dgit import $treeimporthow $package $cversion]
1905 END
1906
1907     close C or die $!;
1908     my $rawimport_hash = make_commit qw(../commit.tmp);
1909
1910     if (madformat $dsc->{format}) {
1911         printdebug "import apply patches...\n";
1912
1913         # regularise the state of the working tree so that
1914         # the checkout of $rawimport_hash works nicely.
1915         my $dappliedcommit = make_commit_text(<<END);
1916 tree $dappliedtree
1917 author $authline
1918 committer $authline
1919
1920 [dgit dummy commit]
1921 END
1922         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
1923
1924         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
1925
1926         # We need the answers to be reproducible
1927         my @authline = clogp_authline($clogp);
1928         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
1929         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
1930         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
1931         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
1932         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
1933         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
1934
1935         eval {
1936             runcmd shell_cmd 'exec >/dev/null 2>../../gbp-pq-output',
1937                 gbp_pq, qw(import);
1938         };
1939         if ($@) {
1940             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
1941             die $@;
1942         }
1943
1944         my $gapplied = git_rev_parse('HEAD');
1945         my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
1946         $gappliedtree eq $dappliedtree or
1947             fail <<END;
1948 gbp-pq import and dpkg-source disagree!
1949  gbp-pq import gave commit $gapplied
1950  gbp-pq import gave tree $gappliedtree
1951  dpkg-source --before-build gave tree $dappliedtree
1952 END
1953         $rawimport_hash = $gapplied;
1954     }
1955
1956     progress "synthesised git commit from .dsc $cversion";
1957
1958     my $rawimport_mergeinput = {
1959         Commit => $rawimport_hash,
1960         Info => "Import of source package",
1961     };
1962     my @output = ($rawimport_mergeinput);
1963
1964     if ($lastpush_mergeinput) {
1965         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
1966         my $oversion = getfield $oldclogp, 'Version';
1967         my $vcmp =
1968             version_compare($oversion, $cversion);
1969         if ($vcmp < 0) {
1970             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
1971                 { Message => <<END, ReverseParents => 1 });
1972 Record $package ($cversion) in archive suite $csuite
1973 END
1974         } elsif ($vcmp > 0) {
1975             print STDERR <<END or die $!;
1976
1977 Version actually in archive:   $cversion (older)
1978 Last version pushed with dgit: $oversion (newer or same)
1979 $later_warning_msg
1980 END
1981             @output = $lastpush_mergeinput;
1982         } else {
1983             # Same version.  Use what's in the server git branch,
1984             # discarding our own import.  (This could happen if the
1985             # server automatically imports all packages into git.)
1986             @output = $lastpush_mergeinput;
1987         }
1988     }
1989     changedir '../../../..';
1990     rmtree($ud);
1991     return @output;
1992 }
1993
1994 sub complete_file_from_dsc ($$) {
1995     our ($dstdir, $fi) = @_;
1996     # Ensures that we have, in $dir, the file $fi, with the correct
1997     # contents.  (Downloading it from alongside $dscurl if necessary.)
1998
1999     my $f = $fi->{Filename};
2000     my $tf = "$dstdir/$f";
2001     my $downloaded = 0;
2002
2003     if (stat_exists $tf) {
2004         progress "using existing $f";
2005     } else {
2006         my $furl = $dscurl;
2007         $furl =~ s{/[^/]+$}{};
2008         $furl .= "/$f";
2009         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2010         die "$f ?" if $f =~ m#/#;
2011         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
2012         return 0 if !act_local();
2013         $downloaded = 1;
2014     }
2015
2016     open F, "<", "$tf" or die "$tf: $!";
2017     $fi->{Digester}->reset();
2018     $fi->{Digester}->addfile(*F);
2019     F->error and die $!;
2020     my $got = $fi->{Digester}->hexdigest();
2021     $got eq $fi->{Hash} or
2022         fail "file $f has hash $got but .dsc".
2023             " demands hash $fi->{Hash} ".
2024             ($downloaded ? "(got wrong file from archive!)"
2025              : "(perhaps you should delete this file?)");
2026
2027     return 1;
2028 }
2029
2030 sub ensure_we_have_orig () {
2031     my @dfi = dsc_files_info();
2032     foreach my $fi (@dfi) {
2033         my $f = $fi->{Filename};
2034         next unless is_orig_file_in_dsc($f, \@dfi);
2035         complete_file_from_dsc('..', $fi)
2036             or next;
2037     }
2038 }
2039
2040 sub git_fetch_us () {
2041     # Want to fetch only what we are going to use, unless
2042     # deliberately-not-ff, in which case we must fetch everything.
2043
2044     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2045         map { "tags/$_" }
2046         (quiltmode_splitbrain
2047          ? (map { $_->('*',access_basedistro) }
2048             \&debiantag_new, \&debiantag_maintview)
2049          : debiantags('*',access_basedistro));
2050     push @specs, server_branch($csuite);
2051     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2052
2053     # This is rather miserable:
2054     # When git-fetch --prune is passed a fetchspec ending with a *,
2055     # it does a plausible thing.  If there is no * then:
2056     # - it matches subpaths too, even if the supplied refspec
2057     #   starts refs, and behaves completely madly if the source
2058     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2059     # - if there is no matching remote ref, it bombs out the whole
2060     #   fetch.
2061     # We want to fetch a fixed ref, and we don't know in advance
2062     # if it exists, so this is not suitable.
2063     #
2064     # Our workaround is to use git-ls-remote.  git-ls-remote has its
2065     # own qairks.  Notably, it has the absurd multi-tail-matching
2066     # behaviour: git-ls-remote R refs/foo can report refs/foo AND
2067     # refs/refs/foo etc.
2068     #
2069     # Also, we want an idempotent snapshot, but we have to make two
2070     # calls to the remote: one to git-ls-remote and to git-fetch.  The
2071     # solution is use git-ls-remote to obtain a target state, and
2072     # git-fetch to try to generate it.  If we don't manage to generate
2073     # the target state, we try again.
2074
2075     my $specre = join '|', map {
2076         my $x = $_;
2077         $x =~ s/\W/\\$&/g;
2078         $x =~ s/\\\*$/.*/;
2079         "(?:refs/$x)";
2080     } @specs;
2081     printdebug "git_fetch_us specre=$specre\n";
2082     my $wanted_rref = sub {
2083         local ($_) = @_;
2084         return m/^(?:$specre)$/o;
2085     };
2086
2087     my $fetch_iteration = 0;
2088     FETCH_ITERATION:
2089     for (;;) {
2090         if (++$fetch_iteration > 10) {
2091             fail "too many iterations trying to get sane fetch!";
2092         }
2093
2094         my @look = map { "refs/$_" } @specs;
2095         my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2096         debugcmd "|",@lcmd;
2097
2098         my %wantr;
2099         open GITLS, "-|", @lcmd or die $!;
2100         while (<GITLS>) {
2101             printdebug "=> ", $_;
2102             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2103             my ($objid,$rrefname) = ($1,$2);
2104             if (!$wanted_rref->($rrefname)) {
2105                 print STDERR <<END;
2106 warning: git-ls-remote @look reported $rrefname; this is silly, ignoring it.
2107 END
2108                 next;
2109             }
2110             $wantr{$rrefname} = $objid;
2111         }
2112         $!=0; $?=0;
2113         close GITLS or failedcmd @lcmd;
2114
2115         # OK, now %want is exactly what we want for refs in @specs
2116         my @fspecs = map {
2117             return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2118             "+refs/$_:".lrfetchrefs."/$_";
2119         } @specs;
2120
2121         my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2122         runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2123             @fspecs;
2124
2125         %lrfetchrefs_f = ();
2126         my %objgot;
2127
2128         git_for_each_ref(lrfetchrefs, sub {
2129             my ($objid,$objtype,$lrefname,$reftail) = @_;
2130             $lrfetchrefs_f{$lrefname} = $objid;
2131             $objgot{$objid} = 1;
2132         });
2133
2134         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2135             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2136             if (!exists $wantr{$rrefname}) {
2137                 if ($wanted_rref->($rrefname)) {
2138                     printdebug <<END;
2139 git-fetch @fspecs created $lrefname which git-ls-remote @look didn't list.
2140 END
2141                 } else {
2142                     print STDERR <<END
2143 warning: git-fetch @fspecs created $lrefname; this is silly, deleting it.
2144 END
2145                 }
2146                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2147                 delete $lrfetchrefs_f{$lrefname};
2148                 next;
2149             }
2150         }
2151         foreach my $rrefname (sort keys %wantr) {
2152             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2153             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2154             my $want = $wantr{$rrefname};
2155             next if $got eq $want;
2156             if (!defined $objgot{$want}) {
2157                 print STDERR <<END;
2158 warning: git-ls-remote suggests we want $lrefname
2159 warning:  and it should refer to $want
2160 warning:  but git-fetch didn't fetch that object to any relevant ref.
2161 warning:  This may be due to a race with someone updating the server.
2162 warning:  Will try again...
2163 END
2164                 next FETCH_ITERATION;
2165             }
2166             printdebug <<END;
2167 git-fetch @fspecs made $lrefname=$got but want git-ls-remote @look says $want
2168 END
2169             runcmd_ordryrun_local @git, qw(update-ref -m),
2170                 "dgit fetch git-fetch fixup", $lrefname, $want;
2171             $lrfetchrefs_f{$lrefname} = $want;
2172         }
2173         last;
2174     }
2175     printdebug "git_fetch_us: git-fetch --no-insane emulation complete\n",
2176         Dumper(\%lrfetchrefs_f);
2177
2178     my %here;
2179     my @tagpats = debiantags('*',access_basedistro);
2180
2181     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2182         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2183         printdebug "currently $fullrefname=$objid\n";
2184         $here{$fullrefname} = $objid;
2185     });
2186     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2187         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2188         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2189         printdebug "offered $lref=$objid\n";
2190         if (!defined $here{$lref}) {
2191             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2192             runcmd_ordryrun_local @upd;
2193             lrfetchref_used $fullrefname;
2194         } elsif ($here{$lref} eq $objid) {
2195             lrfetchref_used $fullrefname;
2196         } else {
2197             print STDERR \
2198                 "Not updateting $lref from $here{$lref} to $objid.\n";
2199         }
2200     });
2201 }
2202
2203 sub mergeinfo_getclogp ($) {
2204     # Ensures thit $mi->{Clogp} exists and returns it
2205     my ($mi) = @_;
2206     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2207 }
2208
2209 sub mergeinfo_version ($) {
2210     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2211 }
2212
2213 sub fetch_from_archive () {
2214     ensure_setup_existing_tree();
2215
2216     # Ensures that lrref() is what is actually in the archive, one way
2217     # or another, according to us - ie this client's
2218     # appropritaely-updated archive view.  Also returns the commit id.
2219     # If there is nothing in the archive, leaves lrref alone and
2220     # returns undef.  git_fetch_us must have already been called.
2221     get_archive_dsc();
2222
2223     if ($dsc) {
2224         foreach my $field (@ourdscfield) {
2225             $dsc_hash = $dsc->{$field};
2226             last if defined $dsc_hash;
2227         }
2228         if (defined $dsc_hash) {
2229             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2230             $dsc_hash = $&;
2231             progress "last upload to archive specified git hash";
2232         } else {
2233             progress "last upload to archive has NO git hash";
2234         }
2235     } else {
2236         progress "no version available from the archive";
2237     }
2238
2239     # If the archive's .dsc has a Dgit field, there are three
2240     # relevant git commitids we need to choose between and/or merge
2241     # together:
2242     #   1. $dsc_hash: the Dgit field from the archive
2243     #   2. $lastpush_hash: the suite branch on the dgit git server
2244     #   3. $lastfetch_hash: our local tracking brach for the suite
2245     #
2246     # These may all be distinct and need not be in any fast forward
2247     # relationship:
2248     #
2249     # If the dsc was pushed to this suite, then the server suite
2250     # branch will have been updated; but it might have been pushed to
2251     # a different suite and copied by the archive.  Conversely a more
2252     # recent version may have been pushed with dgit but not appeared
2253     # in the archive (yet).
2254     #
2255     # $lastfetch_hash may be awkward because archive imports
2256     # (particularly, imports of Dgit-less .dscs) are performed only as
2257     # needed on individual clients, so different clients may perform a
2258     # different subset of them - and these imports are only made
2259     # public during push.  So $lastfetch_hash may represent a set of
2260     # imports different to a subsequent upload by a different dgit
2261     # client.
2262     #
2263     # Our approach is as follows:
2264     #
2265     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2266     # descendant of $dsc_hash, then it was pushed by a dgit user who
2267     # had based their work on $dsc_hash, so we should prefer it.
2268     # Otherwise, $dsc_hash was installed into this suite in the
2269     # archive other than by a dgit push, and (necessarily) after the
2270     # last dgit push into that suite (since a dgit push would have
2271     # been descended from the dgit server git branch); thus, in that
2272     # case, we prefer the archive's version (and produce a
2273     # pseudo-merge to overwrite the dgit server git branch).
2274     #
2275     # (If there is no Dgit field in the archive's .dsc then
2276     # generate_commit_from_dsc uses the version numbers to decide
2277     # whether the suite branch or the archive is newer.  If the suite
2278     # branch is newer it ignores the archive's .dsc; otherwise it
2279     # generates an import of the .dsc, and produces a pseudo-merge to
2280     # overwrite the suite branch with the archive contents.)
2281     #
2282     # The outcome of that part of the algorithm is the `public view',
2283     # and is same for all dgit clients: it does not depend on any
2284     # unpublished history in the local tracking branch.
2285     #
2286     # As between the public view and the local tracking branch: The
2287     # local tracking branch is only updated by dgit fetch, and
2288     # whenever dgit fetch runs it includes the public view in the
2289     # local tracking branch.  Therefore if the public view is not
2290     # descended from the local tracking branch, the local tracking
2291     # branch must contain history which was imported from the archive
2292     # but never pushed; and, its tip is now out of date.  So, we make
2293     # a pseudo-merge to overwrite the old imports and stitch the old
2294     # history in.
2295     #
2296     # Finally: we do not necessarily reify the public view (as
2297     # described above).  This is so that we do not end up stacking two
2298     # pseudo-merges.  So what we actually do is figure out the inputs
2299     # to any public view pseudo-merge and put them in @mergeinputs.
2300
2301     my @mergeinputs;
2302     # $mergeinputs[]{Commit}
2303     # $mergeinputs[]{Info}
2304     # $mergeinputs[0] is the one whose tree we use
2305     # @mergeinputs is in the order we use in the actual commit)
2306     #
2307     # Also:
2308     # $mergeinputs[]{Message} is a commit message to use
2309     # $mergeinputs[]{ReverseParents} if def specifies that parent
2310     #                                list should be in opposite order
2311     # Such an entry has no Commit or Info.  It applies only when found
2312     # in the last entry.  (This ugliness is to support making
2313     # identical imports to previous dgit versions.)
2314
2315     my $lastpush_hash = git_get_ref(lrfetchref());
2316     printdebug "previous reference hash=$lastpush_hash\n";
2317     $lastpush_mergeinput = $lastpush_hash && {
2318         Commit => $lastpush_hash,
2319         Info => "dgit suite branch on dgit git server",
2320     };
2321
2322     my $lastfetch_hash = git_get_ref(lrref());
2323     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2324     my $lastfetch_mergeinput = $lastfetch_hash && {
2325         Commit => $lastfetch_hash,
2326         Info => "dgit client's archive history view",
2327     };
2328
2329     my $dsc_mergeinput = $dsc_hash && {
2330         Commit => $dsc_hash,
2331         Info => "Dgit field in .dsc from archive",
2332     };
2333
2334     my $cwd = getcwd();
2335     my $del_lrfetchrefs = sub {
2336         changedir $cwd;
2337         my $gur;
2338         printdebug "del_lrfetchrefs...\n";
2339         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2340             my $objid = $lrfetchrefs_d{$fullrefname};
2341             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2342             if (!$gur) {
2343                 $gur ||= new IO::Handle;
2344                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2345             }
2346             printf $gur "delete %s %s\n", $fullrefname, $objid;
2347         }
2348         if ($gur) {
2349             close $gur or failedcmd "git update-ref delete lrfetchrefs";
2350         }
2351     };
2352
2353     if (defined $dsc_hash) {
2354         fail "missing remote git history even though dsc has hash -".
2355             " could not find ref ".rref()." at ".access_giturl()
2356             unless $lastpush_hash;
2357         ensure_we_have_orig();
2358         if ($dsc_hash eq $lastpush_hash) {
2359             @mergeinputs = $dsc_mergeinput
2360         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2361             print STDERR <<END or die $!;
2362
2363 Git commit in archive is behind the last version allegedly pushed/uploaded.
2364 Commit referred to by archive: $dsc_hash
2365 Last version pushed with dgit: $lastpush_hash
2366 $later_warning_msg
2367 END
2368             @mergeinputs = ($lastpush_mergeinput);
2369         } else {
2370             # Archive has .dsc which is not a descendant of the last dgit
2371             # push.  This can happen if the archive moves .dscs about.
2372             # Just follow its lead.
2373             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2374                 progress "archive .dsc names newer git commit";
2375                 @mergeinputs = ($dsc_mergeinput);
2376             } else {
2377                 progress "archive .dsc names other git commit, fixing up";
2378                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2379             }
2380         }
2381     } elsif ($dsc) {
2382         @mergeinputs = generate_commits_from_dsc();
2383         # We have just done an import.  Now, our import algorithm might
2384         # have been improved.  But even so we do not want to generate
2385         # a new different import of the same package.  So if the
2386         # version numbers are the same, just use our existing version.
2387         # If the version numbers are different, the archive has changed
2388         # (perhaps, rewound).
2389         if ($lastfetch_mergeinput &&
2390             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2391                               (mergeinfo_version $mergeinputs[0]) )) {
2392             @mergeinputs = ($lastfetch_mergeinput);
2393         }
2394     } elsif ($lastpush_hash) {
2395         # only in git, not in the archive yet
2396         @mergeinputs = ($lastpush_mergeinput);
2397         print STDERR <<END or die $!;
2398
2399 Package not found in the archive, but has allegedly been pushed using dgit.
2400 $later_warning_msg
2401 END
2402     } else {
2403         printdebug "nothing found!\n";
2404         if (defined $skew_warning_vsn) {
2405             print STDERR <<END or die $!;
2406
2407 Warning: relevant archive skew detected.
2408 Archive allegedly contains $skew_warning_vsn
2409 But we were not able to obtain any version from the archive or git.
2410
2411 END
2412         }
2413         unshift @end, $del_lrfetchrefs;
2414         return undef;
2415     }
2416
2417     if ($lastfetch_hash &&
2418         !grep {
2419             my $h = $_->{Commit};
2420             $h and is_fast_fwd($lastfetch_hash, $h);
2421             # If true, one of the existing parents of this commit
2422             # is a descendant of the $lastfetch_hash, so we'll
2423             # be ff from that automatically.
2424         } @mergeinputs
2425         ) {
2426         # Otherwise:
2427         push @mergeinputs, $lastfetch_mergeinput;
2428     }
2429
2430     printdebug "fetch mergeinfos:\n";
2431     foreach my $mi (@mergeinputs) {
2432         if ($mi->{Info}) {
2433             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2434         } else {
2435             printdebug sprintf " ReverseParents=%d Message=%s",
2436                 $mi->{ReverseParents}, $mi->{Message};
2437         }
2438     }
2439
2440     my $compat_info= pop @mergeinputs
2441         if $mergeinputs[$#mergeinputs]{Message};
2442
2443     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2444
2445     my $hash;
2446     if (@mergeinputs > 1) {
2447         # here we go, then:
2448         my $tree_commit = $mergeinputs[0]{Commit};
2449
2450         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2451         $tree =~ m/\n\n/;  $tree = $`;
2452         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2453         $tree = $1;
2454
2455         # We use the changelog author of the package in question the
2456         # author of this pseudo-merge.  This is (roughly) correct if
2457         # this commit is simply representing aa non-dgit upload.
2458         # (Roughly because it does not record sponsorship - but we
2459         # don't have sponsorship info because that's in the .changes,
2460         # which isn't in the archivw.)
2461         #
2462         # But, it might be that we are representing archive history
2463         # updates (including in-archive copies).  These are not really
2464         # the responsibility of the person who created the .dsc, but
2465         # there is no-one whose name we should better use.  (The
2466         # author of the .dsc-named commit is clearly worse.)
2467
2468         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2469         my $author = clogp_authline $useclogp;
2470         my $cversion = getfield $useclogp, 'Version';
2471
2472         my $mcf = ".git/dgit/mergecommit";
2473         open MC, ">", $mcf or die "$mcf $!";
2474         print MC <<END or die $!;
2475 tree $tree
2476 END
2477
2478         my @parents = grep { $_->{Commit} } @mergeinputs;
2479         @parents = reverse @parents if $compat_info->{ReverseParents};
2480         print MC <<END or die $! foreach @parents;
2481 parent $_->{Commit}
2482 END
2483
2484         print MC <<END or die $!;
2485 author $author
2486 committer $author
2487
2488 END
2489
2490         if (defined $compat_info->{Message}) {
2491             print MC $compat_info->{Message} or die $!;
2492         } else {
2493             print MC <<END or die $!;
2494 Record $package ($cversion) in archive suite $csuite
2495
2496 Record that
2497 END
2498             my $message_add_info = sub {
2499                 my ($mi) = (@_);
2500                 my $mversion = mergeinfo_version $mi;
2501                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2502                     or die $!;
2503             };
2504
2505             $message_add_info->($mergeinputs[0]);
2506             print MC <<END or die $!;
2507 should be treated as descended from
2508 END
2509             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2510         }
2511
2512         close MC or die $!;
2513         $hash = make_commit $mcf;
2514     } else {
2515         $hash = $mergeinputs[0]{Commit};
2516     }
2517     printdebug "fetch hash=$hash\n";
2518
2519     my $chkff = sub {
2520         my ($lasth, $what) = @_;
2521         return unless $lasth;
2522         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2523     };
2524
2525     $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2526     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2527
2528     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2529             'DGIT_ARCHIVE', $hash;
2530     cmdoutput @git, qw(log -n2), $hash;
2531     # ... gives git a chance to complain if our commit is malformed
2532
2533     if (defined $skew_warning_vsn) {
2534         mkpath '.git/dgit';
2535         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2536         my $gotclogp = commit_getclogp($hash);
2537         my $got_vsn = getfield $gotclogp, 'Version';
2538         printdebug "SKEW CHECK GOT $got_vsn\n";
2539         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2540             print STDERR <<END or die $!;
2541
2542 Warning: archive skew detected.  Using the available version:
2543 Archive allegedly contains    $skew_warning_vsn
2544 We were able to obtain only   $got_vsn
2545
2546 END
2547         }
2548     }
2549
2550     if ($lastfetch_hash ne $hash) {
2551         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2552         if (act_local()) {
2553             cmdoutput @upd_cmd;
2554         } else {
2555             dryrun_report @upd_cmd;
2556         }
2557     }
2558
2559     lrfetchref_used lrfetchref();
2560
2561     unshift @end, $del_lrfetchrefs;
2562     return $hash;
2563 }
2564
2565 sub set_local_git_config ($$) {
2566     my ($k, $v) = @_;
2567     runcmd @git, qw(config), $k, $v;
2568 }
2569
2570 sub setup_mergechangelogs (;$) {
2571     my ($always) = @_;
2572     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2573
2574     my $driver = 'dpkg-mergechangelogs';
2575     my $cb = "merge.$driver";
2576     my $attrs = '.git/info/attributes';
2577     ensuredir '.git/info';
2578
2579     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2580     if (!open ATTRS, "<", $attrs) {
2581         $!==ENOENT or die "$attrs: $!";
2582     } else {
2583         while (<ATTRS>) {
2584             chomp;
2585             next if m{^debian/changelog\s};
2586             print NATTRS $_, "\n" or die $!;
2587         }
2588         ATTRS->error and die $!;
2589         close ATTRS;
2590     }
2591     print NATTRS "debian/changelog merge=$driver\n" or die $!;
2592     close NATTRS;
2593
2594     set_local_git_config "$cb.name", 'debian/changelog merge driver';
2595     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2596
2597     rename "$attrs.new", "$attrs" or die "$attrs: $!";
2598 }
2599
2600 sub setup_useremail (;$) {
2601     my ($always) = @_;
2602     return unless $always || access_cfg_bool(1, 'setup-useremail');
2603
2604     my $setup = sub {
2605         my ($k, $envvar) = @_;
2606         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2607         return unless defined $v;
2608         set_local_git_config "user.$k", $v;
2609     };
2610
2611     $setup->('email', 'DEBEMAIL');
2612     $setup->('name', 'DEBFULLNAME');
2613 }
2614
2615 sub ensure_setup_existing_tree () {
2616     my $k = "remote.$remotename.skipdefaultupdate";
2617     my $c = git_get_config $k;
2618     return if defined $c;
2619     set_local_git_config $k, 'true';
2620 }
2621
2622 sub setup_new_tree () {
2623     setup_mergechangelogs();
2624     setup_useremail();
2625 }
2626
2627 sub clone ($) {
2628     my ($dstdir) = @_;
2629     canonicalise_suite();
2630     badusage "dry run makes no sense with clone" unless act_local();
2631     my $hasgit = check_for_git();
2632     mkdir $dstdir or fail "create \`$dstdir': $!";
2633     changedir $dstdir;
2634     runcmd @git, qw(init -q);
2635     my $giturl = access_giturl(1);
2636     if (defined $giturl) {
2637         open H, "> .git/HEAD" or die $!;
2638         print H "ref: ".lref()."\n" or die $!;
2639         close H or die $!;
2640         runcmd @git, qw(remote add), 'origin', $giturl;
2641     }
2642     if ($hasgit) {
2643         progress "fetching existing git history";
2644         git_fetch_us();
2645         runcmd_ordryrun_local @git, qw(fetch origin);
2646     } else {
2647         progress "starting new git history";
2648     }
2649     fetch_from_archive() or no_such_package;
2650     my $vcsgiturl = $dsc->{'Vcs-Git'};
2651     if (length $vcsgiturl) {
2652         $vcsgiturl =~ s/\s+-b\s+\S+//g;
2653         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2654     }
2655     setup_new_tree();
2656     runcmd @git, qw(reset --hard), lrref();
2657     printdone "ready for work in $dstdir";
2658 }
2659
2660 sub fetch () {
2661     if (check_for_git()) {
2662         git_fetch_us();
2663     }
2664     fetch_from_archive() or no_such_package();
2665     printdone "fetched into ".lrref();
2666 }
2667
2668 sub pull () {
2669     fetch();
2670     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2671         lrref();
2672     printdone "fetched to ".lrref()." and merged into HEAD";
2673 }
2674
2675 sub check_not_dirty () {
2676     foreach my $f (qw(local-options local-patch-header)) {
2677         if (stat_exists "debian/source/$f") {
2678             fail "git tree contains debian/source/$f";
2679         }
2680     }
2681
2682     return if $ignoredirty;
2683
2684     my @cmd = (@git, qw(diff --quiet HEAD));
2685     debugcmd "+",@cmd;
2686     $!=0; $?=-1; system @cmd;
2687     return if !$?;
2688     if ($?==256) {
2689         fail "working tree is dirty (does not match HEAD)";
2690     } else {
2691         failedcmd @cmd;
2692     }
2693 }
2694
2695 sub commit_admin ($) {
2696     my ($m) = @_;
2697     progress "$m";
2698     runcmd_ordryrun_local @git, qw(commit -m), $m;
2699 }
2700
2701 sub commit_quilty_patch () {
2702     my $output = cmdoutput @git, qw(status --porcelain);
2703     my %adds;
2704     foreach my $l (split /\n/, $output) {
2705         next unless $l =~ m/\S/;
2706         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2707             $adds{$1}++;
2708         }
2709     }
2710     delete $adds{'.pc'}; # if there wasn't one before, don't add it
2711     if (!%adds) {
2712         progress "nothing quilty to commit, ok.";
2713         return;
2714     }
2715     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2716     runcmd_ordryrun_local @git, qw(add -f), @adds;
2717     commit_admin <<END
2718 Commit Debian 3.0 (quilt) metadata
2719
2720 [dgit ($our_version) quilt-fixup]
2721 END
2722 }
2723
2724 sub get_source_format () {
2725     my %options;
2726     if (open F, "debian/source/options") {
2727         while (<F>) {
2728             next if m/^\s*\#/;
2729             next unless m/\S/;
2730             s/\s+$//; # ignore missing final newline
2731             if (m/\s*\#\s*/) {
2732                 my ($k, $v) = ($`, $'); #');
2733                 $v =~ s/^"(.*)"$/$1/;
2734                 $options{$k} = $v;
2735             } else {
2736                 $options{$_} = 1;
2737             }
2738         }
2739         F->error and die $!;
2740         close F;
2741     } else {
2742         die $! unless $!==&ENOENT;
2743     }
2744
2745     if (!open F, "debian/source/format") {
2746         die $! unless $!==&ENOENT;
2747         return '';
2748     }
2749     $_ = <F>;
2750     F->error and die $!;
2751     chomp;
2752     return ($_, \%options);
2753 }
2754
2755 sub madformat_wantfixup ($) {
2756     my ($format) = @_;
2757     return 0 unless $format eq '3.0 (quilt)';
2758     our $quilt_mode_warned;
2759     if ($quilt_mode eq 'nocheck') {
2760         progress "Not doing any fixup of \`$format' due to".
2761             " ----no-quilt-fixup or --quilt=nocheck"
2762             unless $quilt_mode_warned++;
2763         return 0;
2764     }
2765     progress "Format \`$format', need to check/update patch stack"
2766         unless $quilt_mode_warned++;
2767     return 1;
2768 }
2769
2770 # An "infopair" is a tuple [ $thing, $what ]
2771 # (often $thing is a commit hash; $what is a description)
2772
2773 sub infopair_cond_equal ($$) {
2774     my ($x,$y) = @_;
2775     $x->[0] eq $y->[0] or fail <<END;
2776 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2777 END
2778 };
2779
2780 sub infopair_lrf_tag_lookup ($$) {
2781     my ($tagnames, $what) = @_;
2782     # $tagname may be an array ref
2783     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2784     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2785     foreach my $tagname (@tagnames) {
2786         my $lrefname = lrfetchrefs."/tags/$tagname";
2787         my $tagobj = $lrfetchrefs_f{$lrefname};
2788         next unless defined $tagobj;
2789         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2790         return [ git_rev_parse($tagobj), $what ];
2791     }
2792     fail @tagnames==1 ? <<END : <<END;
2793 Wanted tag $what (@tagnames) on dgit server, but not found
2794 END
2795 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2796 END
2797 }
2798
2799 sub infopair_cond_ff ($$) {
2800     my ($anc,$desc) = @_;
2801     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2802 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2803 END
2804 };
2805
2806 sub pseudomerge_version_check ($$) {
2807     my ($clogp, $archive_hash) = @_;
2808
2809     my $arch_clogp = commit_getclogp $archive_hash;
2810     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2811                      'version currently in archive' ];
2812     if (defined $overwrite_version) {
2813         if (length $overwrite_version) {
2814             infopair_cond_equal([ $overwrite_version,
2815                                   '--overwrite= version' ],
2816                                 $i_arch_v);
2817         } else {
2818             my $v = $i_arch_v->[0];
2819             progress "Checking package changelog for archive version $v ...";
2820             eval {
2821                 my @xa = ("-f$v", "-t$v");
2822                 my $vclogp = parsechangelog @xa;
2823                 my $cv = [ (getfield $vclogp, 'Version'),
2824                            "Version field from dpkg-parsechangelog @xa" ];
2825                 infopair_cond_equal($i_arch_v, $cv);
2826             };
2827             if ($@) {
2828                 $@ =~ s/^dgit: //gm;
2829                 fail "$@".
2830                     "Perhaps debian/changelog does not mention $v ?";
2831             }
2832         }
2833     }
2834     
2835     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2836     return $i_arch_v;
2837 }
2838
2839 sub pseudomerge_make_commit ($$$$ $$) {
2840     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2841         $msg_cmd, $msg_msg) = @_;
2842     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2843
2844     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2845     my $authline = clogp_authline $clogp;
2846
2847     chomp $msg_msg;
2848     $msg_cmd .=
2849         !defined $overwrite_version ? ""
2850         : !length  $overwrite_version ? " --overwrite"
2851         : " --overwrite=".$overwrite_version;
2852
2853     mkpath '.git/dgit';
2854     my $pmf = ".git/dgit/pseudomerge";
2855     open MC, ">", $pmf or die "$pmf $!";
2856     print MC <<END or die $!;
2857 tree $tree
2858 parent $dgitview
2859 parent $archive_hash
2860 author $authline
2861 commiter $authline
2862
2863 $msg_msg
2864
2865 [$msg_cmd]
2866 END
2867     close MC or die $!;
2868
2869     return make_commit($pmf);
2870 }
2871
2872 sub splitbrain_pseudomerge ($$$$) {
2873     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2874     # => $merged_dgitview
2875     printdebug "splitbrain_pseudomerge...\n";
2876     #
2877     #     We:      debian/PREVIOUS    HEAD($maintview)
2878     # expect:          o ----------------- o
2879     #                    \                   \
2880     #                     o                   o
2881     #                 a/d/PREVIOUS        $dgitview
2882     #                $archive_hash              \
2883     #  If so,                \                   \
2884     #  we do:                 `------------------ o
2885     #   this:                                   $dgitview'
2886     #
2887
2888     printdebug "splitbrain_pseudomerge...\n";
2889
2890     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2891
2892     return $dgitview unless defined $archive_hash;
2893
2894     if (!defined $overwrite_version) {
2895         progress "Checking that HEAD inciudes all changes in archive...";
2896     }
2897
2898     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2899
2900     my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2901     my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2902     my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2903     my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2904     my $i_archive = [ $archive_hash, "current archive contents" ];
2905
2906     printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2907
2908     infopair_cond_equal($i_dgit, $i_archive);
2909     infopair_cond_ff($i_dep14, $i_dgit);
2910     $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2911
2912     my $r = pseudomerge_make_commit
2913         $clogp, $dgitview, $archive_hash, $i_arch_v,
2914         "dgit --quilt=$quilt_mode",
2915         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2916 Declare fast forward from $overwrite_version
2917 END_OVERWR
2918 Make fast forward from $i_arch_v->[0]
2919 END_MAKEFF
2920
2921     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2922     return $r;
2923 }       
2924
2925 sub plain_overwrite_pseudomerge ($$$) {
2926     my ($clogp, $head, $archive_hash) = @_;
2927
2928     printdebug "plain_overwrite_pseudomerge...";
2929
2930     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2931
2932     my @tagformats = access_cfg_tagformats();
2933     my @t_overwr =
2934         map { $_->($i_arch_v->[0], access_basedistro) }
2935         (grep { m/^(?:old|hist)$/ } @tagformats)
2936         ? \&debiantags : \&debiantag_new;
2937     my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2938     my $i_archive = [ $archive_hash, "current archive contents" ];
2939
2940     infopair_cond_equal($i_overwr, $i_archive);
2941
2942     return $head if is_fast_fwd $archive_hash, $head;
2943
2944     my $m = "Declare fast forward from $i_arch_v->[0]";
2945
2946     my $r = pseudomerge_make_commit
2947         $clogp, $head, $archive_hash, $i_arch_v,
2948         "dgit", $m;
2949
2950     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2951
2952     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2953     return $r;
2954 }
2955
2956 sub push_parse_changelog ($) {
2957     my ($clogpfn) = @_;
2958
2959     my $clogp = Dpkg::Control::Hash->new();
2960     $clogp->load($clogpfn) or die;
2961
2962     $package = getfield $clogp, 'Source';
2963     my $cversion = getfield $clogp, 'Version';
2964     my $tag = debiantag($cversion, access_basedistro);
2965     runcmd @git, qw(check-ref-format), $tag;
2966
2967     my $dscfn = dscfn($cversion);
2968
2969     return ($clogp, $cversion, $dscfn);
2970 }
2971
2972 sub push_parse_dsc ($$$) {
2973     my ($dscfn,$dscfnwhat, $cversion) = @_;
2974     $dsc = parsecontrol($dscfn,$dscfnwhat);
2975     my $dversion = getfield $dsc, 'Version';
2976     my $dscpackage = getfield $dsc, 'Source';
2977     ($dscpackage eq $package && $dversion eq $cversion) or
2978         fail "$dscfn is for $dscpackage $dversion".
2979             " but debian/changelog is for $package $cversion";
2980 }
2981
2982 sub push_tagwants ($$$$) {
2983     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2984     my @tagwants;
2985     push @tagwants, {
2986         TagFn => \&debiantag,
2987         Objid => $dgithead,
2988         TfSuffix => '',
2989         View => 'dgit',
2990     };
2991     if (defined $maintviewhead) {
2992         push @tagwants, {
2993             TagFn => \&debiantag_maintview,
2994             Objid => $maintviewhead,
2995             TfSuffix => '-maintview',
2996             View => 'maint',
2997         };
2998     }
2999     foreach my $tw (@tagwants) {
3000         $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3001         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3002     }
3003     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3004     return @tagwants;
3005 }
3006
3007 sub push_mktags ($$ $$ $) {
3008     my ($clogp,$dscfn,
3009         $changesfile,$changesfilewhat,
3010         $tagwants) = @_;
3011
3012     die unless $tagwants->[0]{View} eq 'dgit';
3013
3014     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3015     $dsc->save("$dscfn.tmp") or die $!;
3016
3017     my $changes = parsecontrol($changesfile,$changesfilewhat);
3018     foreach my $field (qw(Source Distribution Version)) {
3019         $changes->{$field} eq $clogp->{$field} or
3020             fail "changes field $field \`$changes->{$field}'".
3021                 " does not match changelog \`$clogp->{$field}'";
3022     }
3023
3024     my $cversion = getfield $clogp, 'Version';
3025     my $clogsuite = getfield $clogp, 'Distribution';
3026
3027     # We make the git tag by hand because (a) that makes it easier
3028     # to control the "tagger" (b) we can do remote signing
3029     my $authline = clogp_authline $clogp;
3030     my $delibs = join(" ", "",@deliberatelies);
3031     my $declaredistro = access_basedistro();
3032
3033     my $mktag = sub {
3034         my ($tw) = @_;
3035         my $tfn = $tw->{Tfn};
3036         my $head = $tw->{Objid};
3037         my $tag = $tw->{Tag};
3038
3039         open TO, '>', $tfn->('.tmp') or die $!;
3040         print TO <<END or die $!;
3041 object $head
3042 type commit
3043 tag $tag
3044 tagger $authline
3045
3046 END
3047         if ($tw->{View} eq 'dgit') {
3048             print TO <<END or die $!;
3049 $package release $cversion for $clogsuite ($csuite) [dgit]
3050 [dgit distro=$declaredistro$delibs]
3051 END
3052             foreach my $ref (sort keys %previously) {
3053                 print TO <<END or die $!;
3054 [dgit previously:$ref=$previously{$ref}]
3055 END
3056             }
3057         } elsif ($tw->{View} eq 'maint') {
3058             print TO <<END or die $!;
3059 $package release $cversion for $clogsuite ($csuite)
3060 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3061 END
3062         } else {
3063             die Dumper($tw)."?";
3064         }
3065
3066         close TO or die $!;
3067
3068         my $tagobjfn = $tfn->('.tmp');
3069         if ($sign) {
3070             if (!defined $keyid) {
3071                 $keyid = access_cfg('keyid','RETURN-UNDEF');
3072             }
3073             if (!defined $keyid) {
3074                 $keyid = getfield $clogp, 'Maintainer';
3075             }
3076             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3077             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3078             push @sign_cmd, qw(-u),$keyid if defined $keyid;
3079             push @sign_cmd, $tfn->('.tmp');
3080             runcmd_ordryrun @sign_cmd;
3081             if (act_scary()) {
3082                 $tagobjfn = $tfn->('.signed.tmp');
3083                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3084                     $tfn->('.tmp'), $tfn->('.tmp.asc');
3085             }
3086         }
3087         return $tagobjfn;
3088     };
3089
3090     my @r = map { $mktag->($_); } @$tagwants;
3091     return @r;
3092 }
3093
3094 sub sign_changes ($) {
3095     my ($changesfile) = @_;
3096     if ($sign) {
3097         my @debsign_cmd = @debsign;
3098         push @debsign_cmd, "-k$keyid" if defined $keyid;
3099         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3100         push @debsign_cmd, $changesfile;
3101         runcmd_ordryrun @debsign_cmd;
3102     }
3103 }
3104
3105 sub dopush () {
3106     printdebug "actually entering push\n";
3107
3108     supplementary_message(<<'END');
3109 Push failed, while checking state of the archive.
3110 You can retry the push, after fixing the problem, if you like.
3111 END
3112     if (check_for_git()) {
3113         git_fetch_us();
3114     }
3115     my $archive_hash = fetch_from_archive();
3116     if (!$archive_hash) {
3117         $new_package or
3118             fail "package appears to be new in this suite;".
3119                 " if this is intentional, use --new";
3120     }
3121
3122     supplementary_message(<<'END');
3123 Push failed, while preparing your push.
3124 You can retry the push, after fixing the problem, if you like.
3125 END
3126
3127     need_tagformat 'new', "quilt mode $quilt_mode"
3128         if quiltmode_splitbrain;
3129
3130     prep_ud();
3131
3132     access_giturl(); # check that success is vaguely likely
3133     select_tagformat();
3134
3135     my $clogpfn = ".git/dgit/changelog.822.tmp";
3136     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3137
3138     responder_send_file('parsed-changelog', $clogpfn);
3139
3140     my ($clogp, $cversion, $dscfn) =
3141         push_parse_changelog("$clogpfn");
3142
3143     my $dscpath = "$buildproductsdir/$dscfn";
3144     stat_exists $dscpath or
3145         fail "looked for .dsc $dscfn, but $!;".
3146             " maybe you forgot to build";
3147
3148     responder_send_file('dsc', $dscpath);
3149
3150     push_parse_dsc($dscpath, $dscfn, $cversion);
3151
3152     my $format = getfield $dsc, 'Format';
3153     printdebug "format $format\n";
3154
3155     my $actualhead = git_rev_parse('HEAD');
3156     my $dgithead = $actualhead;
3157     my $maintviewhead = undef;
3158
3159     if (madformat_wantfixup($format)) {
3160         # user might have not used dgit build, so maybe do this now:
3161         if (quiltmode_splitbrain()) {
3162             my $upstreamversion = $clogp->{Version};
3163             $upstreamversion =~ s/-[^-]*$//;
3164             changedir $ud;
3165             quilt_make_fake_dsc($upstreamversion);
3166             my ($dgitview, $cachekey) =
3167                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3168             $dgitview or fail
3169  "--quilt=$quilt_mode but no cached dgit view:
3170  perhaps tree changed since dgit build[-source] ?";
3171             $split_brain = 1;
3172             $dgithead = splitbrain_pseudomerge($clogp,
3173                                                $actualhead, $dgitview,
3174                                                $archive_hash);
3175             $maintviewhead = $actualhead;
3176             changedir '../../../..';
3177             prep_ud(); # so _only_subdir() works, below
3178         } else {
3179             commit_quilty_patch();
3180         }
3181     }
3182
3183     if (defined $overwrite_version && !defined $maintviewhead) {
3184         $dgithead = plain_overwrite_pseudomerge($clogp,
3185                                                 $dgithead,
3186                                                 $archive_hash);
3187     }
3188
3189     check_not_dirty();
3190
3191     my $forceflag = '';
3192     if ($archive_hash) {
3193         if (is_fast_fwd($archive_hash, $dgithead)) {
3194             # ok
3195         } elsif (deliberately_not_fast_forward) {
3196             $forceflag = '+';
3197         } else {
3198             fail "dgit push: HEAD is not a descendant".
3199                 " of the archive's version.\n".
3200                 "To overwrite the archive's contents,".
3201                 " pass --overwrite[=VERSION].\n".
3202                 "To rewind history, if permitted by the archive,".
3203                 " use --deliberately-not-fast-forward.";
3204         }
3205     }
3206
3207     changedir $ud;
3208     progress "checking that $dscfn corresponds to HEAD";
3209     runcmd qw(dpkg-source -x --),
3210         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3211     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3212     check_for_vendor_patches() if madformat($dsc->{format});
3213     changedir '../../../..';
3214     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3215     debugcmd "+",@diffcmd;
3216     $!=0; $?=-1;
3217     my $r = system @diffcmd;
3218     if ($r) {
3219         if ($r==256) {
3220             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3221             fail <<END
3222 HEAD specifies a different tree to $dscfn:
3223 $diffs
3224 Perhaps you forgot to build.  Or perhaps there is a problem with your
3225  source tree (see dgit(7) for some hints).  To see a full diff, run
3226    git diff $tree HEAD
3227 END
3228         } else {
3229             failedcmd @diffcmd;
3230         }
3231     }
3232     if (!$changesfile) {
3233         my $pat = changespat $cversion;
3234         my @cs = glob "$buildproductsdir/$pat";
3235         fail "failed to find unique changes file".
3236             " (looked for $pat in $buildproductsdir);".
3237             " perhaps you need to use dgit -C"
3238             unless @cs==1;
3239         ($changesfile) = @cs;
3240     } else {
3241         $changesfile = "$buildproductsdir/$changesfile";
3242     }
3243
3244     # Check that changes and .dsc agree enough
3245     $changesfile =~ m{[^/]*$};
3246     files_compare_inputs($dsc, parsecontrol($changesfile,$&));
3247
3248     # Checks complete, we're going to try and go ahead:
3249
3250     responder_send_file('changes',$changesfile);
3251     responder_send_command("param head $dgithead");
3252     responder_send_command("param csuite $csuite");
3253     responder_send_command("param tagformat $tagformat");
3254     if (defined $maintviewhead) {
3255         die unless ($protovsn//4) >= 4;
3256         responder_send_command("param maint-view $maintviewhead");
3257     }
3258
3259     if (deliberately_not_fast_forward) {
3260         git_for_each_ref(lrfetchrefs, sub {
3261             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3262             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3263             responder_send_command("previously $rrefname=$objid");
3264             $previously{$rrefname} = $objid;
3265         });
3266     }
3267
3268     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3269                                  ".git/dgit/tag");
3270     my @tagobjfns;
3271
3272     supplementary_message(<<'END');
3273 Push failed, while signing the tag.
3274 You can retry the push, after fixing the problem, if you like.
3275 END
3276     # If we manage to sign but fail to record it anywhere, it's fine.
3277     if ($we_are_responder) {
3278         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3279         responder_receive_files('signed-tag', @tagobjfns);
3280     } else {
3281         @tagobjfns = push_mktags($clogp,$dscpath,
3282                               $changesfile,$changesfile,
3283                               \@tagwants);
3284     }
3285     supplementary_message(<<'END');
3286 Push failed, *after* signing the tag.
3287 If you want to try again, you should use a new version number.
3288 END
3289
3290     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3291
3292     foreach my $tw (@tagwants) {
3293         my $tag = $tw->{Tag};
3294         my $tagobjfn = $tw->{TagObjFn};
3295         my $tag_obj_hash =
3296             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3297         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3298         runcmd_ordryrun_local
3299             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3300     }
3301
3302     supplementary_message(<<'END');
3303 Push failed, while updating the remote git repository - see messages above.
3304 If you want to try again, you should use a new version number.
3305 END
3306     if (!check_for_git()) {
3307         create_remote_git_repo();
3308     }
3309
3310     my @pushrefs = $forceflag.$dgithead.":".rrref();
3311     foreach my $tw (@tagwants) {
3312         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3313     }
3314
3315     runcmd_ordryrun @git,
3316         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3317     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3318
3319     supplementary_message(<<'END');
3320 Push failed, after updating the remote git repository.
3321 If you want to try again, you must use a new version number.
3322 END
3323     if ($we_are_responder) {
3324         my $dryrunsuffix = act_local() ? "" : ".tmp";
3325         responder_receive_files('signed-dsc-changes',
3326                                 "$dscpath$dryrunsuffix",
3327                                 "$changesfile$dryrunsuffix");
3328     } else {
3329         if (act_local()) {
3330             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3331         } else {
3332             progress "[new .dsc left in $dscpath.tmp]";
3333         }
3334         sign_changes $changesfile;
3335     }
3336
3337     supplementary_message(<<END);
3338 Push failed, while uploading package(s) to the archive server.
3339 You can retry the upload of exactly these same files with dput of:
3340   $changesfile
3341 If that .changes file is broken, you will need to use a new version
3342 number for your next attempt at the upload.
3343 END
3344     my $host = access_cfg('upload-host','RETURN-UNDEF');
3345     my @hostarg = defined($host) ? ($host,) : ();
3346     runcmd_ordryrun @dput, @hostarg, $changesfile;
3347     printdone "pushed and uploaded $cversion";
3348
3349     supplementary_message('');
3350     responder_send_command("complete");
3351 }
3352
3353 sub cmd_clone {
3354     parseopts();
3355     notpushing();
3356     my $dstdir;
3357     badusage "-p is not allowed with clone; specify as argument instead"
3358         if defined $package;
3359     if (@ARGV==1) {
3360         ($package) = @ARGV;
3361     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3362         ($package,$isuite) = @ARGV;
3363     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3364         ($package,$dstdir) = @ARGV;
3365     } elsif (@ARGV==3) {
3366         ($package,$isuite,$dstdir) = @ARGV;
3367     } else {
3368         badusage "incorrect arguments to dgit clone";
3369     }
3370     $dstdir ||= "$package";
3371
3372     if (stat_exists $dstdir) {
3373         fail "$dstdir already exists";
3374     }
3375
3376     my $cwd_remove;
3377     if ($rmonerror && !$dryrun_level) {
3378         $cwd_remove= getcwd();
3379         unshift @end, sub { 
3380             return unless defined $cwd_remove;
3381             if (!chdir "$cwd_remove") {
3382                 return if $!==&ENOENT;
3383                 die "chdir $cwd_remove: $!";
3384             }
3385             if (stat $dstdir) {
3386                 rmtree($dstdir) or die "remove $dstdir: $!\n";
3387             } elsif (grep { $! == $_ }
3388                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3389             } else {
3390                 print STDERR "check whether to remove $dstdir: $!\n";
3391             }
3392         };
3393     }
3394
3395     clone($dstdir);
3396     $cwd_remove = undef;
3397 }
3398
3399 sub branchsuite () {
3400     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3401     if ($branch =~ m#$lbranch_re#o) {
3402         return $1;
3403     } else {
3404         return undef;
3405     }
3406 }
3407
3408 sub fetchpullargs () {
3409     notpushing();
3410     if (!defined $package) {
3411         my $sourcep = parsecontrol('debian/control','debian/control');
3412         $package = getfield $sourcep, 'Source';
3413     }
3414     if (@ARGV==0) {
3415 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
3416         if (!$isuite) {
3417             my $clogp = parsechangelog();
3418             $isuite = getfield $clogp, 'Distribution';
3419         }
3420         canonicalise_suite();
3421         progress "fetching from suite $csuite";
3422     } elsif (@ARGV==1) {
3423         ($isuite) = @ARGV;
3424         canonicalise_suite();
3425     } else {
3426         badusage "incorrect arguments to dgit fetch or dgit pull";
3427     }
3428 }
3429
3430 sub cmd_fetch {
3431     parseopts();
3432     fetchpullargs();
3433     fetch();
3434 }
3435
3436 sub cmd_pull {
3437     parseopts();
3438     fetchpullargs();
3439     pull();
3440 }
3441
3442 sub cmd_push {
3443     parseopts();
3444     pushing();
3445     badusage "-p is not allowed with dgit push" if defined $package;
3446     check_not_dirty();
3447     my $clogp = parsechangelog();
3448     $package = getfield $clogp, 'Source';
3449     my $specsuite;
3450     if (@ARGV==0) {
3451     } elsif (@ARGV==1) {
3452         ($specsuite) = (@ARGV);
3453     } else {
3454         badusage "incorrect arguments to dgit push";
3455     }
3456     $isuite = getfield $clogp, 'Distribution';
3457     if ($new_package) {
3458         local ($package) = $existing_package; # this is a hack
3459         canonicalise_suite();
3460     } else {
3461         canonicalise_suite();
3462     }
3463     if (defined $specsuite &&
3464         $specsuite ne $isuite &&
3465         $specsuite ne $csuite) {
3466             fail "dgit push: changelog specifies $isuite ($csuite)".
3467                 " but command line specifies $specsuite";
3468     }
3469     dopush();
3470 }
3471
3472 #---------- remote commands' implementation ----------
3473
3474 sub cmd_remote_push_build_host {
3475     my ($nrargs) = shift @ARGV;
3476     my (@rargs) = @ARGV[0..$nrargs-1];
3477     @ARGV = @ARGV[$nrargs..$#ARGV];
3478     die unless @rargs;
3479     my ($dir,$vsnwant) = @rargs;
3480     # vsnwant is a comma-separated list; we report which we have
3481     # chosen in our ready response (so other end can tell if they
3482     # offered several)
3483     $debugprefix = ' ';
3484     $we_are_responder = 1;
3485     $us .= " (build host)";
3486
3487     pushing();
3488
3489     open PI, "<&STDIN" or die $!;
3490     open STDIN, "/dev/null" or die $!;
3491     open PO, ">&STDOUT" or die $!;
3492     autoflush PO 1;
3493     open STDOUT, ">&STDERR" or die $!;
3494     autoflush STDOUT 1;
3495
3496     $vsnwant //= 1;
3497     ($protovsn) = grep {
3498         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3499     } @rpushprotovsn_support;
3500
3501     fail "build host has dgit rpush protocol versions ".
3502         (join ",", @rpushprotovsn_support).
3503         " but invocation host has $vsnwant"
3504         unless defined $protovsn;
3505
3506     responder_send_command("dgit-remote-push-ready $protovsn");
3507     rpush_handle_protovsn_bothends();
3508     changedir $dir;
3509     &cmd_push;
3510 }
3511
3512 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3513 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3514 #     a good error message)
3515
3516 sub rpush_handle_protovsn_bothends () {
3517     if ($protovsn < 4) {
3518         need_tagformat 'old', "rpush negotiated protocol $protovsn";
3519     }
3520     select_tagformat();
3521 }
3522
3523 our $i_tmp;
3524
3525 sub i_cleanup {
3526     local ($@, $?);
3527     my $report = i_child_report();
3528     if (defined $report) {
3529         printdebug "($report)\n";
3530     } elsif ($i_child_pid) {
3531         printdebug "(killing build host child $i_child_pid)\n";
3532         kill 15, $i_child_pid;
3533     }
3534     if (defined $i_tmp && !defined $initiator_tempdir) {
3535         changedir "/";
3536         eval { rmtree $i_tmp; };
3537     }
3538 }
3539
3540 END { i_cleanup(); }
3541
3542 sub i_method {
3543     my ($base,$selector,@args) = @_;
3544     $selector =~ s/\-/_/g;
3545     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3546 }
3547
3548 sub cmd_rpush {
3549     pushing();
3550     my $host = nextarg;
3551     my $dir;
3552     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3553         $host = $1;
3554         $dir = $'; #';
3555     } else {
3556         $dir = nextarg;
3557     }
3558     $dir =~ s{^-}{./-};
3559     my @rargs = ($dir);
3560     push @rargs, join ",", @rpushprotovsn_support;
3561     my @rdgit;
3562     push @rdgit, @dgit;
3563     push @rdgit, @ropts;
3564     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3565     push @rdgit, @ARGV;
3566     my @cmd = (@ssh, $host, shellquote @rdgit);
3567     debugcmd "+",@cmd;
3568
3569     if (defined $initiator_tempdir) {
3570         rmtree $initiator_tempdir;
3571         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3572         $i_tmp = $initiator_tempdir;
3573     } else {
3574         $i_tmp = tempdir();
3575     }
3576     $i_child_pid = open2(\*RO, \*RI, @cmd);
3577     changedir $i_tmp;
3578     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3579     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3580     $supplementary_message = '' unless $protovsn >= 3;
3581
3582     fail "rpush negotiated protocol version $protovsn".
3583         " which does not support quilt mode $quilt_mode"
3584         if quiltmode_splitbrain;
3585
3586     rpush_handle_protovsn_bothends();
3587     for (;;) {
3588         my ($icmd,$iargs) = initiator_expect {
3589             m/^(\S+)(?: (.*))?$/;
3590             ($1,$2);
3591         };
3592         i_method "i_resp", $icmd, $iargs;
3593     }
3594 }
3595
3596 sub i_resp_progress ($) {
3597     my ($rhs) = @_;
3598     my $msg = protocol_read_bytes \*RO, $rhs;
3599     progress $msg;
3600 }
3601
3602 sub i_resp_supplementary_message ($) {
3603     my ($rhs) = @_;
3604     $supplementary_message = protocol_read_bytes \*RO, $rhs;
3605 }
3606
3607 sub i_resp_complete {
3608     my $pid = $i_child_pid;
3609     $i_child_pid = undef; # prevents killing some other process with same pid
3610     printdebug "waiting for build host child $pid...\n";
3611     my $got = waitpid $pid, 0;
3612     die $! unless $got == $pid;
3613     die "build host child failed $?" if $?;
3614
3615     i_cleanup();
3616     printdebug "all done\n";
3617     exit 0;
3618 }
3619
3620 sub i_resp_file ($) {
3621     my ($keyword) = @_;
3622     my $localname = i_method "i_localname", $keyword;
3623     my $localpath = "$i_tmp/$localname";
3624     stat_exists $localpath and
3625         badproto \*RO, "file $keyword ($localpath) twice";
3626     protocol_receive_file \*RO, $localpath;
3627     i_method "i_file", $keyword;
3628 }
3629
3630 our %i_param;
3631
3632 sub i_resp_param ($) {
3633     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3634     $i_param{$1} = $2;
3635 }
3636
3637 sub i_resp_previously ($) {
3638     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3639         or badproto \*RO, "bad previously spec";
3640     my $r = system qw(git check-ref-format), $1;
3641     die "bad previously ref spec ($r)" if $r;
3642     $previously{$1} = $2;
3643 }
3644
3645 our %i_wanted;
3646
3647 sub i_resp_want ($) {
3648     my ($keyword) = @_;
3649     die "$keyword ?" if $i_wanted{$keyword}++;
3650     my @localpaths = i_method "i_want", $keyword;
3651     printdebug "[[  $keyword @localpaths\n";
3652     foreach my $localpath (@localpaths) {
3653         protocol_send_file \*RI, $localpath;
3654     }
3655     print RI "files-end\n" or die $!;
3656 }
3657
3658 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3659
3660 sub i_localname_parsed_changelog {
3661     return "remote-changelog.822";
3662 }
3663 sub i_file_parsed_changelog {
3664     ($i_clogp, $i_version, $i_dscfn) =
3665         push_parse_changelog "$i_tmp/remote-changelog.822";
3666     die if $i_dscfn =~ m#/|^\W#;
3667 }
3668
3669 sub i_localname_dsc {
3670     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3671     return $i_dscfn;
3672 }
3673 sub i_file_dsc { }
3674
3675 sub i_localname_changes {
3676     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3677     $i_changesfn = $i_dscfn;
3678     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3679     return $i_changesfn;
3680 }
3681 sub i_file_changes { }
3682
3683 sub i_want_signed_tag {
3684     printdebug Dumper(\%i_param, $i_dscfn);
3685     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3686         && defined $i_param{'csuite'}
3687         or badproto \*RO, "premature desire for signed-tag";
3688     my $head = $i_param{'head'};
3689     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3690
3691     my $maintview = $i_param{'maint-view'};
3692     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3693
3694     select_tagformat();
3695     if ($protovsn >= 4) {
3696         my $p = $i_param{'tagformat'} // '<undef>';
3697         $p eq $tagformat
3698             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3699     }
3700
3701     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3702     $csuite = $&;
3703     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3704
3705     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3706
3707     return
3708         push_mktags $i_clogp, $i_dscfn,
3709             $i_changesfn, 'remote changes',
3710             \@tagwants;
3711 }
3712
3713 sub i_want_signed_dsc_changes {
3714     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3715     sign_changes $i_changesfn;
3716     return ($i_dscfn, $i_changesfn);
3717 }
3718
3719 #---------- building etc. ----------
3720
3721 our $version;
3722 our $sourcechanges;
3723 our $dscfn;
3724
3725 #----- `3.0 (quilt)' handling -----
3726
3727 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3728
3729 sub quiltify_dpkg_commit ($$$;$) {
3730     my ($patchname,$author,$msg, $xinfo) = @_;
3731     $xinfo //= '';
3732
3733     mkpath '.git/dgit';
3734     my $descfn = ".git/dgit/quilt-description.tmp";
3735     open O, '>', $descfn or die "$descfn: $!";
3736     $msg =~ s/\n+/\n\n/;
3737     print O <<END or die $!;
3738 From: $author
3739 ${xinfo}Subject: $msg
3740 ---
3741
3742 END
3743     close O or die $!;
3744
3745     {
3746         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3747         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3748         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3749         runcmd @dpkgsource, qw(--commit .), $patchname;
3750     }
3751 }
3752
3753 sub quiltify_trees_differ ($$;$$$) {
3754     my ($x,$y,$fi