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