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