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