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