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