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