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