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