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