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