chiark / gitweb /
1877e03ec5d317675aa1cc0980bdd7da65dcf76c
[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 f_
1478         "unable to canonicalise suite using package %s".
1479         " which does not appear to exist in suite %s;".
1480         " --existing-package may help",
1481         $package, $isuite;
1482     return $r[0][2];
1483 }
1484
1485 sub file_in_archive_madison { return undef; }
1486 sub package_not_wholly_new_madison { return undef; }
1487
1488 #---------- `sshpsql' archive query method ----------
1489
1490 sub sshpsql ($$$) {
1491     my ($data,$runeinfo,$sql) = @_;
1492     if (!length $data) {
1493         $data= access_someuserhost('sshpsql').':'.
1494             access_cfg('sshpsql-dbname');
1495     }
1496     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1497     my ($userhost,$dbname) = ($`,$'); #';
1498     my @rows;
1499     my @cmd = (access_cfg_ssh, $userhost,
1500                access_runeinfo("ssh-psql $runeinfo").
1501                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1502                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1503     debugcmd "|",@cmd;
1504     open P, "-|", @cmd or die $!;
1505     while (<P>) {
1506         chomp or die;
1507         printdebug(">|$_|\n");
1508         push @rows, $_;
1509     }
1510     $!=0; $?=0; close P or failedcmd @cmd;
1511     @rows or die;
1512     my $nrows = pop @rows;
1513     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1514     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1515     @rows = map { [ split /\|/, $_ ] } @rows;
1516     my $ncols = scalar @{ shift @rows };
1517     die if grep { scalar @$_ != $ncols } @rows;
1518     return @rows;
1519 }
1520
1521 sub sql_injection_check {
1522     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1523 }
1524
1525 sub archive_query_sshpsql ($$) {
1526     my ($proto,$data) = @_;
1527     sql_injection_check $isuite, $package;
1528     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1529         SELECT source.version, component.name, files.filename, files.sha256sum
1530           FROM source
1531           JOIN src_associations ON source.id = src_associations.source
1532           JOIN suite ON suite.id = src_associations.suite
1533           JOIN dsc_files ON dsc_files.source = source.id
1534           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1535           JOIN component ON component.id = files_archive_map.component_id
1536           JOIN files ON files.id = dsc_files.file
1537          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1538            AND source.source='$package'
1539            AND files.filename LIKE '%.dsc';
1540 END
1541     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1542     my $digester = Digest::SHA->new(256);
1543     @rows = map {
1544         my ($vsn,$component,$filename,$sha256sum) = @$_;
1545         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1546     } @rows;
1547     return archive_query_prepend_mirror @rows;
1548 }
1549
1550 sub canonicalise_suite_sshpsql ($$) {
1551     my ($proto,$data) = @_;
1552     sql_injection_check $isuite;
1553     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1554         SELECT suite.codename
1555           FROM suite where suite_name='$isuite' or codename='$isuite';
1556 END
1557     @rows = map { $_->[0] } @rows;
1558     fail "unknown suite $isuite" unless @rows;
1559     die "ambiguous $isuite: @rows ?" if @rows>1;
1560     return $rows[0];
1561 }
1562
1563 sub file_in_archive_sshpsql ($$$) { return undef; }
1564 sub package_not_wholly_new_sshpsql ($$$) { return undef; }
1565
1566 #---------- `dummycat' archive query method ----------
1567
1568 sub canonicalise_suite_dummycat ($$) {
1569     my ($proto,$data) = @_;
1570     my $dpath = "$data/suite.$isuite";
1571     if (!open C, "<", $dpath) {
1572         $!==ENOENT or die "$dpath: $!";
1573         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1574         return $isuite;
1575     }
1576     $!=0; $_ = <C>;
1577     chomp or die "$dpath: $!";
1578     close C;
1579     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1580     return $_;
1581 }
1582
1583 sub archive_query_dummycat ($$) {
1584     my ($proto,$data) = @_;
1585     canonicalise_suite();
1586     my $dpath = "$data/package.$csuite.$package";
1587     if (!open C, "<", $dpath) {
1588         $!==ENOENT or die "$dpath: $!";
1589         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1590         return ();
1591     }
1592     my @rows;
1593     while (<C>) {
1594         next if m/^\#/;
1595         next unless m/\S/;
1596         die unless chomp;
1597         printdebug "dummycat query $csuite $package $dpath | $_\n";
1598         my @row = split /\s+/, $_;
1599         @row==2 or die "$dpath: $_ ?";
1600         push @rows, \@row;
1601     }
1602     C->error and die "$dpath: $!";
1603     close C;
1604     return archive_query_prepend_mirror
1605         sort { -version_compare($a->[0],$b->[0]); } @rows;
1606 }
1607
1608 sub file_in_archive_dummycat () { return undef; }
1609 sub package_not_wholly_new_dummycat () { return undef; }
1610
1611 #---------- tag format handling ----------
1612
1613 sub access_cfg_tagformats () {
1614     split /\,/, access_cfg('dgit-tag-format');
1615 }
1616
1617 sub access_cfg_tagformats_can_splitbrain () {
1618     my %y = map { $_ => 1 } access_cfg_tagformats;
1619     foreach my $needtf (qw(new maint)) {
1620         next if $y{$needtf};
1621         return 0;
1622     }
1623     return 1;
1624 }
1625
1626 sub need_tagformat ($$) {
1627     my ($fmt, $why) = @_;
1628     fail "need to use tag format $fmt ($why) but also need".
1629         " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1630         " - no way to proceed"
1631         if $tagformat_want && $tagformat_want->[0] ne $fmt;
1632     $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1633 }
1634
1635 sub select_tagformat () {
1636     # sets $tagformatfn
1637     return if $tagformatfn && !$tagformat_want;
1638     die 'bug' if $tagformatfn && $tagformat_want;
1639     # ... $tagformat_want assigned after previous select_tagformat
1640
1641     my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1642     printdebug "select_tagformat supported @supported\n";
1643
1644     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1645     printdebug "select_tagformat specified @$tagformat_want\n";
1646
1647     my ($fmt,$why,$override) = @$tagformat_want;
1648
1649     fail "target distro supports tag formats @supported".
1650         " but have to use $fmt ($why)"
1651         unless $override
1652             or grep { $_ eq $fmt } @supported;
1653
1654     $tagformat_want = undef;
1655     $tagformat = $fmt;
1656     $tagformatfn = ${*::}{"debiantag_$fmt"};
1657
1658     fail "trying to use unknown tag format \`$fmt' ($why) !"
1659         unless $tagformatfn;
1660 }
1661
1662 #---------- archive query entrypoints and rest of program ----------
1663
1664 sub canonicalise_suite () {
1665     return if defined $csuite;
1666     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1667     $csuite = archive_query('canonicalise_suite');
1668     if ($isuite ne $csuite) {
1669         progress "canonical suite name for $isuite is $csuite";
1670     } else {
1671         progress "canonical suite name is $csuite";
1672     }
1673 }
1674
1675 sub get_archive_dsc () {
1676     canonicalise_suite();
1677     my @vsns = archive_query('archive_query');
1678     foreach my $vinfo (@vsns) {
1679         my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1680         $dscurl = $vsn_dscurl;
1681         $dscdata = url_get($dscurl);
1682         if (!$dscdata) {
1683             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1684             next;
1685         }
1686         if ($digester) {
1687             $digester->reset();
1688             $digester->add($dscdata);
1689             my $got = $digester->hexdigest();
1690             $got eq $digest or
1691                 fail "$dscurl has hash $got but".
1692                     " archive told us to expect $digest";
1693         }
1694         parse_dscdata();
1695         my $fmt = getfield $dsc, 'Format';
1696         $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1697             "unsupported source format $fmt, sorry";
1698             
1699         $dsc_checked = !!$digester;
1700         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1701         return;
1702     }
1703     $dsc = undef;
1704     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1705 }
1706
1707 sub check_for_git ();
1708 sub check_for_git () {
1709     # returns 0 or 1
1710     my $how = access_cfg('git-check');
1711     if ($how eq 'ssh-cmd') {
1712         my @cmd =
1713             (access_cfg_ssh, access_gituserhost(),
1714              access_runeinfo("git-check $package").
1715              " set -e; cd ".access_cfg('git-path').";".
1716              " if test -d $package.git; then echo 1; else echo 0; fi");
1717         my $r= cmdoutput @cmd;
1718         if (defined $r and $r =~ m/^divert (\w+)$/) {
1719             my $divert=$1;
1720             my ($usedistro,) = access_distros();
1721             # NB that if we are pushing, $usedistro will be $distro/push
1722             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1723             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1724             progress "diverting to $divert (using config for $instead_distro)";
1725             return check_for_git();
1726         }
1727         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1728         return $r+0;
1729     } elsif ($how eq 'url') {
1730         my $prefix = access_cfg('git-check-url','git-url');
1731         my $suffix = access_cfg('git-check-suffix','git-suffix',
1732                                 'RETURN-UNDEF') // '.git';
1733         my $url = "$prefix/$package$suffix";
1734         my @cmd = (@curl, qw(-sS -I), $url);
1735         my $result = cmdoutput @cmd;
1736         $result =~ s/^\S+ 200 .*\n\r?\n//;
1737         # curl -sS -I with https_proxy prints
1738         # HTTP/1.0 200 Connection established
1739         $result =~ m/^\S+ (404|200) /s or
1740             fail "unexpected results from git check query - ".
1741                 Dumper($prefix, $result);
1742         my $code = $1;
1743         if ($code eq '404') {
1744             return 0;
1745         } elsif ($code eq '200') {
1746             return 1;
1747         } else {
1748             die;
1749         }
1750     } elsif ($how eq 'true') {
1751         return 1;
1752     } elsif ($how eq 'false') {
1753         return 0;
1754     } else {
1755         badcfg "unknown git-check \`$how'";
1756     }
1757 }
1758
1759 sub create_remote_git_repo () {
1760     my $how = access_cfg('git-create');
1761     if ($how eq 'ssh-cmd') {
1762         runcmd_ordryrun
1763             (access_cfg_ssh, access_gituserhost(),
1764              access_runeinfo("git-create $package").
1765              "set -e; cd ".access_cfg('git-path').";".
1766              " cp -a _template $package.git");
1767     } elsif ($how eq 'true') {
1768         # nothing to do
1769     } else {
1770         badcfg "unknown git-create \`$how'";
1771     }
1772 }
1773
1774 our ($dsc_hash,$lastpush_mergeinput);
1775 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1776
1777
1778 sub prep_ud () {
1779     dgit_privdir(); # ensures that $dgit_privdir_made is based on $maindir
1780     $playground = fresh_playground 'dgit/unpack';
1781 }
1782
1783 sub mktree_in_ud_here () {
1784     playtree_setup $gitcfgs{local};
1785 }
1786
1787 sub git_write_tree () {
1788     my $tree = cmdoutput @git, qw(write-tree);
1789     $tree =~ m/^\w+$/ or die "$tree ?";
1790     return $tree;
1791 }
1792
1793 sub git_add_write_tree () {
1794     runcmd @git, qw(add -Af .);
1795     return git_write_tree();
1796 }
1797
1798 sub remove_stray_gits ($) {
1799     my ($what) = @_;
1800     my @gitscmd = qw(find -name .git -prune -print0);
1801     debugcmd "|",@gitscmd;
1802     open GITS, "-|", @gitscmd or die $!;
1803     {
1804         local $/="\0";
1805         while (<GITS>) {
1806             chomp or die;
1807             print STDERR "$us: warning: removing from $what: ",
1808                 (messagequote $_), "\n";
1809             rmtree $_;
1810         }
1811     }
1812     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1813 }
1814
1815 sub mktree_in_ud_from_only_subdir ($;$) {
1816     my ($what,$raw) = @_;
1817     # changes into the subdir
1818
1819     my (@dirs) = <*/.>;
1820     die "expected one subdir but found @dirs ?" unless @dirs==1;
1821     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1822     my $dir = $1;
1823     changedir $dir;
1824
1825     remove_stray_gits($what);
1826     mktree_in_ud_here();
1827     if (!$raw) {
1828         my ($format, $fopts) = get_source_format();
1829         if (madformat($format)) {
1830             rmtree '.pc';
1831         }
1832     }
1833
1834     my $tree=git_add_write_tree();
1835     return ($tree,$dir);
1836 }
1837
1838 our @files_csum_info_fields = 
1839     (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1840      ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
1841      ['Files',           'Digest::MD5', 'new()',    'md5sum']);
1842
1843 sub dsc_files_info () {
1844     foreach my $csumi (@files_csum_info_fields) {
1845         my ($fname, $module, $method) = @$csumi;
1846         my $field = $dsc->{$fname};
1847         next unless defined $field;
1848         eval "use $module; 1;" or die $@;
1849         my @out;
1850         foreach (split /\n/, $field) {
1851             next unless m/\S/;
1852             m/^(\w+) (\d+) (\S+)$/ or
1853                 fail "could not parse .dsc $fname line \`$_'";
1854             my $digester = eval "$module"."->$method;" or die $@;
1855             push @out, {
1856                 Hash => $1,
1857                 Bytes => $2,
1858                 Filename => $3,
1859                 Digester => $digester,
1860             };
1861         }
1862         return @out;
1863     }
1864     fail "missing any supported Checksums-* or Files field in ".
1865         $dsc->get_option('name');
1866 }
1867
1868 sub dsc_files () {
1869     map { $_->{Filename} } dsc_files_info();
1870 }
1871
1872 sub files_compare_inputs (@) {
1873     my $inputs = \@_;
1874     my %record;
1875     my %fchecked;
1876
1877     my $showinputs = sub {
1878         return join "; ", map { $_->get_option('name') } @$inputs;
1879     };
1880
1881     foreach my $in (@$inputs) {
1882         my $expected_files;
1883         my $in_name = $in->get_option('name');
1884
1885         printdebug "files_compare_inputs $in_name\n";
1886
1887         foreach my $csumi (@files_csum_info_fields) {
1888             my ($fname) = @$csumi;
1889             printdebug "files_compare_inputs $in_name $fname\n";
1890
1891             my $field = $in->{$fname};
1892             next unless defined $field;
1893
1894             my @files;
1895             foreach (split /\n/, $field) {
1896                 next unless m/\S/;
1897
1898                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1899                     fail "could not parse $in_name $fname line \`$_'";
1900
1901                 printdebug "files_compare_inputs $in_name $fname $f\n";
1902
1903                 push @files, $f;
1904
1905                 my $re = \ $record{$f}{$fname};
1906                 if (defined $$re) {
1907                     $fchecked{$f}{$in_name} = 1;
1908                     $$re eq $info or
1909                         fail "hash or size of $f varies in $fname fields".
1910                         " (between: ".$showinputs->().")";
1911                 } else {
1912                     $$re = $info;
1913                 }
1914             }
1915             @files = sort @files;
1916             $expected_files //= \@files;
1917             "@$expected_files" eq "@files" or
1918                 fail "file list in $in_name varies between hash fields!";
1919         }
1920         $expected_files or
1921             fail "$in_name has no files list field(s)";
1922     }
1923     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1924         if $debuglevel>=2;
1925
1926     grep { keys %$_ == @$inputs-1 } values %fchecked
1927         or fail "no file appears in all file lists".
1928         " (looked in: ".$showinputs->().")";
1929 }
1930
1931 sub is_orig_file_in_dsc ($$) {
1932     my ($f, $dsc_files_info) = @_;
1933     return 0 if @$dsc_files_info <= 1;
1934     # One file means no origs, and the filename doesn't have a "what
1935     # part of dsc" component.  (Consider versions ending `.orig'.)
1936     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1937     return 1;
1938 }
1939
1940 # This function determines whether a .changes file is source-only from
1941 # the point of view of dak.  Thus, it permits *_source.buildinfo
1942 # files.
1943 #
1944 # It does not, however, permit any other buildinfo files.  After a
1945 # source-only upload, the buildds will try to upload files like
1946 # foo_1.2.3_amd64.buildinfo.  If the package maintainer included files
1947 # named like this in their (otherwise) source-only upload, the uploads
1948 # of the buildd can be rejected by dak.  Fixing the resultant
1949 # situation can require manual intervention.  So we block such
1950 # .buildinfo files when the user tells us to perform a source-only
1951 # upload (such as when using the push-source subcommand with the -C
1952 # option, which calls this function).
1953 #
1954 # Note, though, that when dgit is told to prepare a source-only
1955 # upload, such as when subcommands like build-source and push-source
1956 # without -C are used, dgit has a more restrictive notion of
1957 # source-only .changes than dak: such uploads will never include
1958 # *_source.buildinfo files.  This is because there is no use for such
1959 # files when using a tool like dgit to produce the source package, as
1960 # dgit ensures the source is identical to git HEAD.
1961 sub test_source_only_changes ($) {
1962     my ($changes) = @_;
1963     foreach my $l (split /\n/, getfield $changes, 'Files') {
1964         $l =~ m/\S+$/ or next;
1965         # \.tar\.[a-z0-9]+ covers orig.tar and the tarballs in native packages
1966         unless ($& =~ m/(?:\.dsc|\.diff\.gz|\.tar\.[a-z0-9]+|_source\.buildinfo)$/) {
1967             print "purportedly source-only changes polluted by $&\n";
1968             return 0;
1969         }
1970     }
1971     return 1;
1972 }
1973
1974 sub changes_update_origs_from_dsc ($$$$) {
1975     my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1976     my %changes_f;
1977     printdebug "checking origs needed ($upstreamvsn)...\n";
1978     $_ = getfield $changes, 'Files';
1979     m/^\w+ \d+ (\S+ \S+) \S+$/m or
1980         fail "cannot find section/priority from .changes Files field";
1981     my $placementinfo = $1;
1982     my %changed;
1983     printdebug "checking origs needed placement '$placementinfo'...\n";
1984     foreach my $l (split /\n/, getfield $dsc, 'Files') {
1985         $l =~ m/\S+$/ or next;
1986         my $file = $&;
1987         printdebug "origs $file | $l\n";
1988         next unless is_orig_file_of_vsn $file, $upstreamvsn;
1989         printdebug "origs $file is_orig\n";
1990         my $have = archive_query('file_in_archive', $file);
1991         if (!defined $have) {
1992             print STDERR <<END;
1993 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1994 END
1995             return;
1996         }
1997         my $found_same = 0;
1998         my @found_differ;
1999         printdebug "origs $file \$#\$have=$#$have\n";
2000         foreach my $h (@$have) {
2001             my $same = 0;
2002             my @differ;
2003             foreach my $csumi (@files_csum_info_fields) {
2004                 my ($fname, $module, $method, $archivefield) = @$csumi;
2005                 next unless defined $h->{$archivefield};
2006                 $_ = $dsc->{$fname};
2007                 next unless defined;
2008                 m/^(\w+) .* \Q$file\E$/m or
2009                     fail ".dsc $fname missing entry for $file";
2010                 if ($h->{$archivefield} eq $1) {
2011                     $same++;
2012                 } else {
2013                     push @differ,
2014  "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
2015                 }
2016             }
2017             die "$file ".Dumper($h)." ?!" if $same && @differ;
2018             $found_same++
2019                 if $same;
2020             push @found_differ, "archive $h->{filename}: ".join "; ", @differ
2021                 if @differ;
2022         }
2023         printdebug "origs $file f.same=$found_same".
2024             " #f._differ=$#found_differ\n";
2025         if (@found_differ && !$found_same) {
2026             fail join "\n",
2027                 "archive contains $file with different checksum",
2028                 @found_differ;
2029         }
2030         # Now we edit the changes file to add or remove it
2031         foreach my $csumi (@files_csum_info_fields) {
2032             my ($fname, $module, $method, $archivefield) = @$csumi;
2033             next unless defined $changes->{$fname};
2034             if ($found_same) {
2035                 # in archive, delete from .changes if it's there
2036                 $changed{$file} = "removed" if
2037                     $changes->{$fname} =~ s/\n.* \Q$file\E$(?:)$//m;
2038             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)$/m) {
2039                 # not in archive, but it's here in the .changes
2040             } else {
2041                 my $dsc_data = getfield $dsc, $fname;
2042                 $dsc_data =~ m/^(.* \Q$file\E$)$/m or die "$dsc_data $file ?";
2043                 my $extra = $1;
2044                 $extra =~ s/ \d+ /$&$placementinfo /
2045                     or die "$fname $extra >$dsc_data< ?"
2046                     if $fname eq 'Files';
2047                 $changes->{$fname} .= "\n". $extra;
2048                 $changed{$file} = "added";
2049             }
2050         }
2051     }
2052     if (%changed) {
2053         foreach my $file (keys %changed) {
2054             progress sprintf
2055                 "edited .changes for archive .orig contents: %s %s",
2056                 $changed{$file}, $file;
2057         }
2058         my $chtmp = "$changesfile.tmp";
2059         $changes->save($chtmp);
2060         if (act_local()) {
2061             rename $chtmp,$changesfile or die "$changesfile $!";
2062         } else {
2063             progress "[new .changes left in $changesfile]";
2064         }
2065     } else {
2066         progress "$changesfile already has appropriate .orig(s) (if any)";
2067     }
2068 }
2069
2070 sub make_commit ($) {
2071     my ($file) = @_;
2072     return cmdoutput @git, qw(hash-object -w -t commit), $file;
2073 }
2074
2075 sub clogp_authline ($) {
2076     my ($clogp) = @_;
2077     my $author = getfield $clogp, 'Maintainer';
2078     if ($author =~ m/^[^"\@]+\,/) {
2079         # single entry Maintainer field with unquoted comma
2080         $author = ($& =~ y/,//rd).$'; # strip the comma
2081     }
2082     # git wants a single author; any remaining commas in $author
2083     # are by now preceded by @ (or ").  It seems safer to punt on
2084     # "..." for now rather than attempting to dequote or something.
2085     $author =~ s#,.*##ms unless $author =~ m/"/;
2086     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2087     my $authline = "$author $date";
2088     $authline =~ m/$git_authline_re/o or
2089         fail "unexpected commit author line format \`$authline'".
2090         " (was generated from changelog Maintainer field)";
2091     return ($1,$2,$3) if wantarray;
2092     return $authline;
2093 }
2094
2095 sub vendor_patches_distro ($$) {
2096     my ($checkdistro, $what) = @_;
2097     return unless defined $checkdistro;
2098
2099     my $series = "debian/patches/\L$checkdistro\E.series";
2100     printdebug "checking for vendor-specific $series ($what)\n";
2101
2102     if (!open SERIES, "<", $series) {
2103         die "$series $!" unless $!==ENOENT;
2104         return;
2105     }
2106     while (<SERIES>) {
2107         next unless m/\S/;
2108         next if m/^\s+\#/;
2109
2110         print STDERR <<END;
2111
2112 Unfortunately, this source package uses a feature of dpkg-source where
2113 the same source package unpacks to different source code on different
2114 distros.  dgit cannot safely operate on such packages on affected
2115 distros, because the meaning of source packages is not stable.
2116
2117 Please ask the distro/maintainer to remove the distro-specific series
2118 files and use a different technique (if necessary, uploading actually
2119 different packages, if different distros are supposed to have
2120 different code).
2121
2122 END
2123         fail "Found active distro-specific series file for".
2124             " $checkdistro ($what): $series, cannot continue";
2125     }
2126     die "$series $!" if SERIES->error;
2127     close SERIES;
2128 }
2129
2130 sub check_for_vendor_patches () {
2131     # This dpkg-source feature doesn't seem to be documented anywhere!
2132     # But it can be found in the changelog (reformatted):
2133
2134     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
2135     #   Author: Raphael Hertzog <hertzog@debian.org>
2136     #   Date: Sun  Oct  3  09:36:48  2010 +0200
2137
2138     #   dpkg-source: correctly create .pc/.quilt_series with alternate
2139     #   series files
2140     #   
2141     #   If you have debian/patches/ubuntu.series and you were
2142     #   unpacking the source package on ubuntu, quilt was still
2143     #   directed to debian/patches/series instead of
2144     #   debian/patches/ubuntu.series.
2145     #   
2146     #   debian/changelog                        |    3 +++
2147     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
2148     #   2 files changed, 6 insertions(+), 1 deletion(-)
2149
2150     use Dpkg::Vendor;
2151     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2152     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2153                          "Dpkg::Vendor \`current vendor'");
2154     vendor_patches_distro(access_basedistro(),
2155                           "(base) distro being accessed");
2156     vendor_patches_distro(access_nomdistro(),
2157                           "(nominal) distro being accessed");
2158 }
2159
2160 sub generate_commits_from_dsc () {
2161     # See big comment in fetch_from_archive, below.
2162     # See also README.dsc-import.
2163     prep_ud();
2164     changedir $playground;
2165
2166     my @dfi = dsc_files_info();
2167     foreach my $fi (@dfi) {
2168         my $f = $fi->{Filename};
2169         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2170         my $upper_f = (bpd_abs()."/$f");
2171
2172         printdebug "considering reusing $f: ";
2173
2174         if (link_ltarget "$upper_f,fetch", $f) {
2175             printdebug "linked (using ...,fetch).\n";
2176         } elsif ((printdebug "($!) "),
2177                  $! != ENOENT) {
2178             fail "accessing $buildproductsdir/$f,fetch: $!";
2179         } elsif (link_ltarget $upper_f, $f) {
2180             printdebug "linked.\n";
2181         } elsif ((printdebug "($!) "),
2182                  $! != ENOENT) {
2183             fail "accessing $buildproductsdir/$f: $!";
2184         } else {
2185             printdebug "absent.\n";
2186         }
2187
2188         my $refetched;
2189         complete_file_from_dsc('.', $fi, \$refetched)
2190             or next;
2191
2192         printdebug "considering saving $f: ";
2193
2194         if (link $f, $upper_f) {
2195             printdebug "linked.\n";
2196         } elsif ((printdebug "($!) "),
2197                  $! != EEXIST) {
2198             fail "saving $buildproductsdir/$f: $!";
2199         } elsif (!$refetched) {
2200             printdebug "no need.\n";
2201         } elsif (link $f, "$upper_f,fetch") {
2202             printdebug "linked (using ...,fetch).\n";
2203         } elsif ((printdebug "($!) "),
2204                  $! != EEXIST) {
2205             fail "saving $buildproductsdir/$f,fetch: $!";
2206         } else {
2207             printdebug "cannot.\n";
2208         }
2209     }
2210
2211     # We unpack and record the orig tarballs first, so that we only
2212     # need disk space for one private copy of the unpacked source.
2213     # But we can't make them into commits until we have the metadata
2214     # from the debian/changelog, so we record the tree objects now and
2215     # make them into commits later.
2216     my @tartrees;
2217     my $upstreamv = upstreamversion $dsc->{version};
2218     my $orig_f_base = srcfn $upstreamv, '';
2219
2220     foreach my $fi (@dfi) {
2221         # We actually import, and record as a commit, every tarball
2222         # (unless there is only one file, in which case there seems
2223         # little point.
2224
2225         my $f = $fi->{Filename};
2226         printdebug "import considering $f ";
2227         (printdebug "only one dfi\n"), next if @dfi == 1;
2228         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2229         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2230         my $compr_ext = $1;
2231
2232         my ($orig_f_part) =
2233             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2234
2235         printdebug "Y ", (join ' ', map { $_//"(none)" }
2236                           $compr_ext, $orig_f_part
2237                          ), "\n";
2238
2239         my $input = new IO::File $f, '<' or die "$f $!";
2240         my $compr_pid;
2241         my @compr_cmd;
2242
2243         if (defined $compr_ext) {
2244             my $cname =
2245                 Dpkg::Compression::compression_guess_from_filename $f;
2246             fail "Dpkg::Compression cannot handle file $f in source package"
2247                 if defined $compr_ext && !defined $cname;
2248             my $compr_proc =
2249                 new Dpkg::Compression::Process compression => $cname;
2250             @compr_cmd = $compr_proc->get_uncompress_cmdline();
2251             my $compr_fh = new IO::Handle;
2252             my $compr_pid = open $compr_fh, "-|" // die $!;
2253             if (!$compr_pid) {
2254                 open STDIN, "<&", $input or die $!;
2255                 exec @compr_cmd;
2256                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2257             }
2258             $input = $compr_fh;
2259         }
2260
2261         rmtree "_unpack-tar";
2262         mkdir "_unpack-tar" or die $!;
2263         my @tarcmd = qw(tar -x -f -
2264                         --no-same-owner --no-same-permissions
2265                         --no-acls --no-xattrs --no-selinux);
2266         my $tar_pid = fork // die $!;
2267         if (!$tar_pid) {
2268             chdir "_unpack-tar" or die $!;
2269             open STDIN, "<&", $input or die $!;
2270             exec @tarcmd;
2271             die "dgit (child): exec $tarcmd[0]: $!";
2272         }
2273         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2274         !$? or failedcmd @tarcmd;
2275
2276         close $input or
2277             (@compr_cmd ? ($?==SIGPIPE || failedcmd @compr_cmd)
2278              : die $!);
2279         # finally, we have the results in "tarball", but maybe
2280         # with the wrong permissions
2281
2282         runcmd qw(chmod -R +rwX _unpack-tar);
2283         changedir "_unpack-tar";
2284         remove_stray_gits($f);
2285         mktree_in_ud_here();
2286         
2287         my ($tree) = git_add_write_tree();
2288         my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2289         if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2290             $tree = $1;
2291             printdebug "one subtree $1\n";
2292         } else {
2293             printdebug "multiple subtrees\n";
2294         }
2295         changedir "..";
2296         rmtree "_unpack-tar";
2297
2298         my $ent = [ $f, $tree ];
2299         push @tartrees, {
2300             Orig => !!$orig_f_part,
2301             Sort => (!$orig_f_part         ? 2 :
2302                      $orig_f_part =~ m/-/g ? 1 :
2303                                              0),
2304             F => $f,
2305             Tree => $tree,
2306         };
2307     }
2308
2309     @tartrees = sort {
2310         # put any without "_" first (spec is not clear whether files
2311         # are always in the usual order).  Tarballs without "_" are
2312         # the main orig or the debian tarball.
2313         $a->{Sort} <=> $b->{Sort} or
2314         $a->{F}    cmp $b->{F}
2315     } @tartrees;
2316
2317     my $any_orig = grep { $_->{Orig} } @tartrees;
2318
2319     my $dscfn = "$package.dsc";
2320
2321     my $treeimporthow = 'package';
2322
2323     open D, ">", $dscfn or die "$dscfn: $!";
2324     print D $dscdata or die "$dscfn: $!";
2325     close D or die "$dscfn: $!";
2326     my @cmd = qw(dpkg-source);
2327     push @cmd, '--no-check' if $dsc_checked;
2328     if (madformat $dsc->{format}) {
2329         push @cmd, '--skip-patches';
2330         $treeimporthow = 'unpatched';
2331     }
2332     push @cmd, qw(-x --), $dscfn;
2333     runcmd @cmd;
2334
2335     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2336     if (madformat $dsc->{format}) { 
2337         check_for_vendor_patches();
2338     }
2339
2340     my $dappliedtree;
2341     if (madformat $dsc->{format}) {
2342         my @pcmd = qw(dpkg-source --before-build .);
2343         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2344         rmtree '.pc';
2345         $dappliedtree = git_add_write_tree();
2346     }
2347
2348     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2349     my $clogp;
2350     my $r1clogp;
2351
2352     printdebug "import clog search...\n";
2353     parsechangelog_loop \@clogcmd, "package changelog", sub {
2354         my ($thisstanza, $desc) = @_;
2355         no warnings qw(exiting);
2356
2357         $clogp //= $thisstanza;
2358
2359         printdebug "import clog $thisstanza->{version} $desc...\n";
2360
2361         last if !$any_orig; # we don't need $r1clogp
2362
2363         # We look for the first (most recent) changelog entry whose
2364         # version number is lower than the upstream version of this
2365         # package.  Then the last (least recent) previous changelog
2366         # entry is treated as the one which introduced this upstream
2367         # version and used for the synthetic commits for the upstream
2368         # tarballs.
2369
2370         # One might think that a more sophisticated algorithm would be
2371         # necessary.  But: we do not want to scan the whole changelog
2372         # file.  Stopping when we see an earlier version, which
2373         # necessarily then is an earlier upstream version, is the only
2374         # realistic way to do that.  Then, either the earliest
2375         # changelog entry we have seen so far is indeed the earliest
2376         # upload of this upstream version; or there are only changelog
2377         # entries relating to later upstream versions (which is not
2378         # possible unless the changelog and .dsc disagree about the
2379         # version).  Then it remains to choose between the physically
2380         # last entry in the file, and the one with the lowest version
2381         # number.  If these are not the same, we guess that the
2382         # versions were created in a non-monotonic order rather than
2383         # that the changelog entries have been misordered.
2384
2385         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2386
2387         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2388         $r1clogp = $thisstanza;
2389
2390         printdebug "import clog $r1clogp->{version} becomes r1\n";
2391     };
2392
2393     $clogp or fail "package changelog has no entries!";
2394
2395     my $authline = clogp_authline $clogp;
2396     my $changes = getfield $clogp, 'Changes';
2397     $changes =~ s/^\n//; # Changes: \n
2398     my $cversion = getfield $clogp, 'Version';
2399
2400     if (@tartrees) {
2401         $r1clogp //= $clogp; # maybe there's only one entry;
2402         my $r1authline = clogp_authline $r1clogp;
2403         # Strictly, r1authline might now be wrong if it's going to be
2404         # unused because !$any_orig.  Whatever.
2405
2406         printdebug "import tartrees authline   $authline\n";
2407         printdebug "import tartrees r1authline $r1authline\n";
2408
2409         foreach my $tt (@tartrees) {
2410             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2411
2412             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2413 tree $tt->{Tree}
2414 author $r1authline
2415 committer $r1authline
2416
2417 Import $tt->{F}
2418
2419 [dgit import orig $tt->{F}]
2420 END_O
2421 tree $tt->{Tree}
2422 author $authline
2423 committer $authline
2424
2425 Import $tt->{F}
2426
2427 [dgit import tarball $package $cversion $tt->{F}]
2428 END_T
2429         }
2430     }
2431
2432     printdebug "import main commit\n";
2433
2434     open C, ">../commit.tmp" or die $!;
2435     print C <<END or die $!;
2436 tree $tree
2437 END
2438     print C <<END or die $! foreach @tartrees;
2439 parent $_->{Commit}
2440 END
2441     print C <<END or die $!;
2442 author $authline
2443 committer $authline
2444
2445 $changes
2446
2447 [dgit import $treeimporthow $package $cversion]
2448 END
2449
2450     close C or die $!;
2451     my $rawimport_hash = make_commit qw(../commit.tmp);
2452
2453     if (madformat $dsc->{format}) {
2454         printdebug "import apply patches...\n";
2455
2456         # regularise the state of the working tree so that
2457         # the checkout of $rawimport_hash works nicely.
2458         my $dappliedcommit = make_commit_text(<<END);
2459 tree $dappliedtree
2460 author $authline
2461 committer $authline
2462
2463 [dgit dummy commit]
2464 END
2465         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2466
2467         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2468
2469         # We need the answers to be reproducible
2470         my @authline = clogp_authline($clogp);
2471         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2472         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2473         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2474         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2475         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2476         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2477
2478         my $path = $ENV{PATH} or die;
2479
2480         # we use ../../gbp-pq-output, which (given that we are in
2481         # $playground/PLAYTREE, and $playground is .git/dgit/unpack,
2482         # is .git/dgit.
2483
2484         foreach my $use_absurd (qw(0 1)) {
2485             runcmd @git, qw(checkout -q unpa);
2486             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2487             local $ENV{PATH} = $path;
2488             if ($use_absurd) {
2489                 chomp $@;
2490                 progress "warning: $@";
2491                 $path = "$absurdity:$path";
2492                 progress "$us: trying slow absurd-git-apply...";
2493                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2494                     or $!==ENOENT
2495                     or die $!;
2496             }
2497             eval {
2498                 die "forbid absurd git-apply\n" if $use_absurd
2499                     && forceing [qw(import-gitapply-no-absurd)];
2500                 die "only absurd git-apply!\n" if !$use_absurd
2501                     && forceing [qw(import-gitapply-absurd)];
2502
2503                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2504                 local $ENV{PATH} = $path                    if $use_absurd;
2505
2506                 my @showcmd = (gbp_pq, qw(import));
2507                 my @realcmd = shell_cmd
2508                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2509                 debugcmd "+",@realcmd;
2510                 if (system @realcmd) {
2511                     die +(shellquote @showcmd).
2512                         " failed: ".
2513                         failedcmd_waitstatus()."\n";
2514                 }
2515
2516                 my $gapplied = git_rev_parse('HEAD');
2517                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2518                 $gappliedtree eq $dappliedtree or
2519                     fail <<END;
2520 gbp-pq import and dpkg-source disagree!
2521  gbp-pq import gave commit $gapplied
2522  gbp-pq import gave tree $gappliedtree
2523  dpkg-source --before-build gave tree $dappliedtree
2524 END
2525                 $rawimport_hash = $gapplied;
2526             };
2527             last unless $@;
2528         }
2529         if ($@) {
2530             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2531             die $@;
2532         }
2533     }
2534
2535     progress "synthesised git commit from .dsc $cversion";
2536
2537     my $rawimport_mergeinput = {
2538         Commit => $rawimport_hash,
2539         Info => "Import of source package",
2540     };
2541     my @output = ($rawimport_mergeinput);
2542
2543     if ($lastpush_mergeinput) {
2544         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2545         my $oversion = getfield $oldclogp, 'Version';
2546         my $vcmp =
2547             version_compare($oversion, $cversion);
2548         if ($vcmp < 0) {
2549             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2550                 { Message => <<END, ReverseParents => 1 });
2551 Record $package ($cversion) in archive suite $csuite
2552 END
2553         } elsif ($vcmp > 0) {
2554             print STDERR <<END or die $!;
2555
2556 Version actually in archive:   $cversion (older)
2557 Last version pushed with dgit: $oversion (newer or same)
2558 $later_warning_msg
2559 END
2560             @output = $lastpush_mergeinput;
2561         } else {
2562             # Same version.  Use what's in the server git branch,
2563             # discarding our own import.  (This could happen if the
2564             # server automatically imports all packages into git.)
2565             @output = $lastpush_mergeinput;
2566         }
2567     }
2568     changedir $maindir;
2569     rmtree $playground;
2570     return @output;
2571 }
2572
2573 sub complete_file_from_dsc ($$;$) {
2574     our ($dstdir, $fi, $refetched) = @_;
2575     # Ensures that we have, in $dstdir, the file $fi, with the correct
2576     # contents.  (Downloading it from alongside $dscurl if necessary.)
2577     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2578     # and will set $$refetched=1 if it did so (or tried to).
2579
2580     my $f = $fi->{Filename};
2581     my $tf = "$dstdir/$f";
2582     my $downloaded = 0;
2583
2584     my $got;
2585     my $checkhash = sub {
2586         open F, "<", "$tf" or die "$tf: $!";
2587         $fi->{Digester}->reset();
2588         $fi->{Digester}->addfile(*F);
2589         F->error and die $!;
2590         $got = $fi->{Digester}->hexdigest();
2591         return $got eq $fi->{Hash};
2592     };
2593
2594     if (stat_exists $tf) {
2595         if ($checkhash->()) {
2596             progress "using existing $f";
2597             return 1;
2598         }
2599         if (!$refetched) {
2600             fail "file $f has hash $got but .dsc".
2601                 " demands hash $fi->{Hash} ".
2602                 "(perhaps you should delete this file?)";
2603         }
2604         progress "need to fetch correct version of $f";
2605         unlink $tf or die "$tf $!";
2606         $$refetched = 1;
2607     } else {
2608         printdebug "$tf does not exist, need to fetch\n";
2609     }
2610
2611     my $furl = $dscurl;
2612     $furl =~ s{/[^/]+$}{};
2613     $furl .= "/$f";
2614     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2615     die "$f ?" if $f =~ m#/#;
2616     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2617     return 0 if !act_local();
2618
2619     $checkhash->() or
2620         fail "file $f has hash $got but .dsc".
2621             " demands hash $fi->{Hash} ".
2622             "(got wrong file from archive!)";
2623
2624     return 1;
2625 }
2626
2627 sub ensure_we_have_orig () {
2628     my @dfi = dsc_files_info();
2629     foreach my $fi (@dfi) {
2630         my $f = $fi->{Filename};
2631         next unless is_orig_file_in_dsc($f, \@dfi);
2632         complete_file_from_dsc($buildproductsdir, $fi)
2633             or next;
2634     }
2635 }
2636
2637 #---------- git fetch ----------
2638
2639 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2640 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2641
2642 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2643 # locally fetched refs because they have unhelpful names and clutter
2644 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2645 # whether we have made another local ref which refers to this object).
2646 #
2647 # (If we deleted them unconditionally, then we might end up
2648 # re-fetching the same git objects each time dgit fetch was run.)
2649 #
2650 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2651 # in git_fetch_us to fetch the refs in question, and possibly a call
2652 # to lrfetchref_used.
2653
2654 our (%lrfetchrefs_f, %lrfetchrefs_d);
2655 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2656
2657 sub lrfetchref_used ($) {
2658     my ($fullrefname) = @_;
2659     my $objid = $lrfetchrefs_f{$fullrefname};
2660     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2661 }
2662
2663 sub git_lrfetch_sane {
2664     my ($url, $supplementary, @specs) = @_;
2665     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2666     # at least as regards @specs.  Also leave the results in
2667     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2668     # able to clean these up.
2669     #
2670     # With $supplementary==1, @specs must not contain wildcards
2671     # and we add to our previous fetches (non-atomically).
2672
2673     # This is rather miserable:
2674     # When git fetch --prune is passed a fetchspec ending with a *,
2675     # it does a plausible thing.  If there is no * then:
2676     # - it matches subpaths too, even if the supplied refspec
2677     #   starts refs, and behaves completely madly if the source
2678     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2679     # - if there is no matching remote ref, it bombs out the whole
2680     #   fetch.
2681     # We want to fetch a fixed ref, and we don't know in advance
2682     # if it exists, so this is not suitable.
2683     #
2684     # Our workaround is to use git ls-remote.  git ls-remote has its
2685     # own qairks.  Notably, it has the absurd multi-tail-matching
2686     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2687     # refs/refs/foo etc.
2688     #
2689     # Also, we want an idempotent snapshot, but we have to make two
2690     # calls to the remote: one to git ls-remote and to git fetch.  The
2691     # solution is use git ls-remote to obtain a target state, and
2692     # git fetch to try to generate it.  If we don't manage to generate
2693     # the target state, we try again.
2694
2695     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2696
2697     my $specre = join '|', map {
2698         my $x = $_;
2699         $x =~ s/\W/\\$&/g;
2700         my $wildcard = $x =~ s/\\\*$/.*/;
2701         die if $wildcard && $supplementary;
2702         "(?:refs/$x)";
2703     } @specs;
2704     printdebug "git_lrfetch_sane specre=$specre\n";
2705     my $wanted_rref = sub {
2706         local ($_) = @_;
2707         return m/^(?:$specre)$/;
2708     };
2709
2710     my $fetch_iteration = 0;
2711     FETCH_ITERATION:
2712     for (;;) {
2713         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2714         if (++$fetch_iteration > 10) {
2715             fail "too many iterations trying to get sane fetch!";
2716         }
2717
2718         my @look = map { "refs/$_" } @specs;
2719         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2720         debugcmd "|",@lcmd;
2721
2722         my %wantr;
2723         open GITLS, "-|", @lcmd or die $!;
2724         while (<GITLS>) {
2725             printdebug "=> ", $_;
2726             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2727             my ($objid,$rrefname) = ($1,$2);
2728             if (!$wanted_rref->($rrefname)) {
2729                 print STDERR <<END;
2730 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2731 END
2732                 next;
2733             }
2734             $wantr{$rrefname} = $objid;
2735         }
2736         $!=0; $?=0;
2737         close GITLS or failedcmd @lcmd;
2738
2739         # OK, now %want is exactly what we want for refs in @specs
2740         my @fspecs = map {
2741             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2742             "+refs/$_:".lrfetchrefs."/$_";
2743         } @specs;
2744
2745         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2746
2747         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2748         runcmd_ordryrun_local @fcmd if @fspecs;
2749
2750         if (!$supplementary) {
2751             %lrfetchrefs_f = ();
2752         }
2753         my %objgot;
2754
2755         git_for_each_ref(lrfetchrefs, sub {
2756             my ($objid,$objtype,$lrefname,$reftail) = @_;
2757             $lrfetchrefs_f{$lrefname} = $objid;
2758             $objgot{$objid} = 1;
2759         });
2760
2761         if ($supplementary) {
2762             last;
2763         }
2764
2765         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2766             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2767             if (!exists $wantr{$rrefname}) {
2768                 if ($wanted_rref->($rrefname)) {
2769                     printdebug <<END;
2770 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2771 END
2772                 } else {
2773                     print STDERR <<END
2774 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2775 END
2776                 }
2777                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2778                 delete $lrfetchrefs_f{$lrefname};
2779                 next;
2780             }
2781         }
2782         foreach my $rrefname (sort keys %wantr) {
2783             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2784             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2785             my $want = $wantr{$rrefname};
2786             next if $got eq $want;
2787             if (!defined $objgot{$want}) {
2788                 fail <<END unless act_local();
2789 --dry-run specified but we actually wanted the results of git fetch,
2790 so this is not going to work.  Try running dgit fetch first,
2791 or using --damp-run instead of --dry-run.
2792 END
2793                 print STDERR <<END;
2794 warning: git ls-remote suggests we want $lrefname
2795 warning:  and it should refer to $want
2796 warning:  but git fetch didn't fetch that object to any relevant ref.
2797 warning:  This may be due to a race with someone updating the server.
2798 warning:  Will try again...
2799 END
2800                 next FETCH_ITERATION;
2801             }
2802             printdebug <<END;
2803 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2804 END
2805             runcmd_ordryrun_local @git, qw(update-ref -m),
2806                 "dgit fetch git fetch fixup", $lrefname, $want;
2807             $lrfetchrefs_f{$lrefname} = $want;
2808         }
2809         last;
2810     }
2811
2812     if (defined $csuite) {
2813         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2814         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2815             my ($objid,$objtype,$lrefname,$reftail) = @_;
2816             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2817             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2818         });
2819     }
2820
2821     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2822         Dumper(\%lrfetchrefs_f);
2823 }
2824
2825 sub git_fetch_us () {
2826     # Want to fetch only what we are going to use, unless
2827     # deliberately-not-ff, in which case we must fetch everything.
2828
2829     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2830         map { "tags/$_" }
2831         (quiltmode_splitbrain
2832          ? (map { $_->('*',access_nomdistro) }
2833             \&debiantag_new, \&debiantag_maintview)
2834          : debiantags('*',access_nomdistro));
2835     push @specs, server_branch($csuite);
2836     push @specs, $rewritemap;
2837     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2838
2839     my $url = access_giturl();
2840     git_lrfetch_sane $url, 0, @specs;
2841
2842     my %here;
2843     my @tagpats = debiantags('*',access_nomdistro);
2844
2845     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2846         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2847         printdebug "currently $fullrefname=$objid\n";
2848         $here{$fullrefname} = $objid;
2849     });
2850     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2851         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2852         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2853         printdebug "offered $lref=$objid\n";
2854         if (!defined $here{$lref}) {
2855             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2856             runcmd_ordryrun_local @upd;
2857             lrfetchref_used $fullrefname;
2858         } elsif ($here{$lref} eq $objid) {
2859             lrfetchref_used $fullrefname;
2860         } else {
2861             print STDERR
2862                 "Not updating $lref from $here{$lref} to $objid.\n";
2863         }
2864     });
2865 }
2866
2867 #---------- dsc and archive handling ----------
2868
2869 sub mergeinfo_getclogp ($) {
2870     # Ensures thit $mi->{Clogp} exists and returns it
2871     my ($mi) = @_;
2872     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2873 }
2874
2875 sub mergeinfo_version ($) {
2876     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2877 }
2878
2879 sub fetch_from_archive_record_1 ($) {
2880     my ($hash) = @_;
2881     runcmd git_update_ref_cmd "dgit fetch $csuite", 'DGIT_ARCHIVE', $hash;
2882     cmdoutput @git, qw(log -n2), $hash;
2883     # ... gives git a chance to complain if our commit is malformed
2884 }
2885
2886 sub fetch_from_archive_record_2 ($) {
2887     my ($hash) = @_;
2888     my @upd_cmd = (git_update_ref_cmd 'dgit fetch', lrref(), $hash);
2889     if (act_local()) {
2890         cmdoutput @upd_cmd;
2891     } else {
2892         dryrun_report @upd_cmd;
2893     }
2894 }
2895
2896 sub parse_dsc_field_def_dsc_distro () {
2897     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2898                            dgit.default.distro);
2899 }
2900
2901 sub parse_dsc_field ($$) {
2902     my ($dsc, $what) = @_;
2903     my $f;
2904     foreach my $field (@ourdscfield) {
2905         $f = $dsc->{$field};
2906         last if defined $f;
2907     }
2908
2909     if (!defined $f) {
2910         progress "$what: NO git hash";
2911         parse_dsc_field_def_dsc_distro();
2912     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2913              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2914         progress "$what: specified git info ($dsc_distro)";
2915         $dsc_hint_tag = [ $dsc_hint_tag ];
2916     } elsif ($f =~ m/^\w+\s*$/) {
2917         $dsc_hash = $&;
2918         parse_dsc_field_def_dsc_distro();
2919         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2920                           $dsc_distro ];
2921         progress "$what: specified git hash";
2922     } else {
2923         fail "$what: invalid Dgit info";
2924     }
2925 }
2926
2927 sub resolve_dsc_field_commit ($$) {
2928     my ($already_distro, $already_mapref) = @_;
2929
2930     return unless defined $dsc_hash;
2931
2932     my $mapref =
2933         defined $already_mapref &&
2934         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2935         ? $already_mapref : undef;
2936
2937     my $do_fetch;
2938     $do_fetch = sub {
2939         my ($what, @fetch) = @_;
2940
2941         local $idistro = $dsc_distro;
2942         my $lrf = lrfetchrefs;
2943
2944         if (!$chase_dsc_distro) {
2945             progress
2946                 "not chasing .dsc distro $dsc_distro: not fetching $what";
2947             return 0;
2948         }
2949
2950         progress
2951             ".dsc names distro $dsc_distro: fetching $what";
2952
2953         my $url = access_giturl();
2954         if (!defined $url) {
2955             defined $dsc_hint_url or fail <<END;
2956 .dsc Dgit metadata is in context of distro $dsc_distro
2957 for which we have no configured url and .dsc provides no hint
2958 END
2959             my $proto =
2960                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2961                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2962             parse_cfg_bool "dsc-url-proto-ok", 'false',
2963                 cfg("dgit.dsc-url-proto-ok.$proto",
2964                     "dgit.default.dsc-url-proto-ok")
2965                 or fail <<END;
2966 .dsc Dgit metadata is in context of distro $dsc_distro
2967 for which we have no configured url;
2968 .dsc provides hinted url with protocol $proto which is unsafe.
2969 (can be overridden by config - consult documentation)
2970 END
2971             $url = $dsc_hint_url;
2972         }
2973
2974         git_lrfetch_sane $url, 1, @fetch;
2975
2976         return $lrf;
2977     };
2978
2979     my $rewrite_enable = do {
2980         local $idistro = $dsc_distro;
2981         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2982     };
2983
2984     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2985         if (!defined $mapref) {
2986             my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2987             $mapref = $lrf.'/'.$rewritemap;
2988         }
2989         my $rewritemapdata = git_cat_file $mapref.':map';
2990         if (defined $rewritemapdata
2991             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2992             progress
2993                 "server's git history rewrite map contains a relevant entry!";
2994
2995             $dsc_hash = $1;
2996             if (defined $dsc_hash) {
2997                 progress "using rewritten git hash in place of .dsc value";
2998             } else {
2999                 progress "server data says .dsc hash is to be disregarded";
3000             }
3001         }
3002     }
3003
3004     if (!defined git_cat_file $dsc_hash) {
3005         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
3006         my $lrf = $do_fetch->("additional commits", @tags) &&
3007             defined git_cat_file $dsc_hash
3008             or fail <<END;
3009 .dsc Dgit metadata requires commit $dsc_hash
3010 but we could not obtain that object anywhere.
3011 END
3012         foreach my $t (@tags) {
3013             my $fullrefname = $lrf.'/'.$t;
3014 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
3015             next unless $lrfetchrefs_f{$fullrefname};
3016             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
3017             lrfetchref_used $fullrefname;
3018         }
3019     }
3020 }
3021
3022 sub fetch_from_archive () {
3023     ensure_setup_existing_tree();
3024
3025     # Ensures that lrref() is what is actually in the archive, one way
3026     # or another, according to us - ie this client's
3027     # appropritaely-updated archive view.  Also returns the commit id.
3028     # If there is nothing in the archive, leaves lrref alone and
3029     # returns undef.  git_fetch_us must have already been called.
3030     get_archive_dsc();
3031
3032     if ($dsc) {
3033         parse_dsc_field($dsc, 'last upload to archive');
3034         resolve_dsc_field_commit access_basedistro,
3035             lrfetchrefs."/".$rewritemap
3036     } else {
3037         progress "no version available from the archive";
3038     }
3039
3040     # If the archive's .dsc has a Dgit field, there are three
3041     # relevant git commitids we need to choose between and/or merge
3042     # together:
3043     #   1. $dsc_hash: the Dgit field from the archive
3044     #   2. $lastpush_hash: the suite branch on the dgit git server
3045     #   3. $lastfetch_hash: our local tracking brach for the suite
3046     #
3047     # These may all be distinct and need not be in any fast forward
3048     # relationship:
3049     #
3050     # If the dsc was pushed to this suite, then the server suite
3051     # branch will have been updated; but it might have been pushed to
3052     # a different suite and copied by the archive.  Conversely a more
3053     # recent version may have been pushed with dgit but not appeared
3054     # in the archive (yet).
3055     #
3056     # $lastfetch_hash may be awkward because archive imports
3057     # (particularly, imports of Dgit-less .dscs) are performed only as
3058     # needed on individual clients, so different clients may perform a
3059     # different subset of them - and these imports are only made
3060     # public during push.  So $lastfetch_hash may represent a set of
3061     # imports different to a subsequent upload by a different dgit
3062     # client.
3063     #
3064     # Our approach is as follows:
3065     #
3066     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
3067     # descendant of $dsc_hash, then it was pushed by a dgit user who
3068     # had based their work on $dsc_hash, so we should prefer it.
3069     # Otherwise, $dsc_hash was installed into this suite in the
3070     # archive other than by a dgit push, and (necessarily) after the
3071     # last dgit push into that suite (since a dgit push would have
3072     # been descended from the dgit server git branch); thus, in that
3073     # case, we prefer the archive's version (and produce a
3074     # pseudo-merge to overwrite the dgit server git branch).
3075     #
3076     # (If there is no Dgit field in the archive's .dsc then
3077     # generate_commit_from_dsc uses the version numbers to decide
3078     # whether the suite branch or the archive is newer.  If the suite
3079     # branch is newer it ignores the archive's .dsc; otherwise it
3080     # generates an import of the .dsc, and produces a pseudo-merge to
3081     # overwrite the suite branch with the archive contents.)
3082     #
3083     # The outcome of that part of the algorithm is the `public view',
3084     # and is same for all dgit clients: it does not depend on any
3085     # unpublished history in the local tracking branch.
3086     #
3087     # As between the public view and the local tracking branch: The
3088     # local tracking branch is only updated by dgit fetch, and
3089     # whenever dgit fetch runs it includes the public view in the
3090     # local tracking branch.  Therefore if the public view is not
3091     # descended from the local tracking branch, the local tracking
3092     # branch must contain history which was imported from the archive
3093     # but never pushed; and, its tip is now out of date.  So, we make
3094     # a pseudo-merge to overwrite the old imports and stitch the old
3095     # history in.
3096     #
3097     # Finally: we do not necessarily reify the public view (as
3098     # described above).  This is so that we do not end up stacking two
3099     # pseudo-merges.  So what we actually do is figure out the inputs
3100     # to any public view pseudo-merge and put them in @mergeinputs.
3101
3102     my @mergeinputs;
3103     # $mergeinputs[]{Commit}
3104     # $mergeinputs[]{Info}
3105     # $mergeinputs[0] is the one whose tree we use
3106     # @mergeinputs is in the order we use in the actual commit)
3107     #
3108     # Also:
3109     # $mergeinputs[]{Message} is a commit message to use
3110     # $mergeinputs[]{ReverseParents} if def specifies that parent
3111     #                                list should be in opposite order
3112     # Such an entry has no Commit or Info.  It applies only when found
3113     # in the last entry.  (This ugliness is to support making
3114     # identical imports to previous dgit versions.)
3115
3116     my $lastpush_hash = git_get_ref(lrfetchref());
3117     printdebug "previous reference hash=$lastpush_hash\n";
3118     $lastpush_mergeinput = $lastpush_hash && {
3119         Commit => $lastpush_hash,
3120         Info => "dgit suite branch on dgit git server",
3121     };
3122
3123     my $lastfetch_hash = git_get_ref(lrref());
3124     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3125     my $lastfetch_mergeinput = $lastfetch_hash && {
3126         Commit => $lastfetch_hash,
3127         Info => "dgit client's archive history view",
3128     };
3129
3130     my $dsc_mergeinput = $dsc_hash && {
3131         Commit => $dsc_hash,
3132         Info => "Dgit field in .dsc from archive",
3133     };
3134
3135     my $cwd = getcwd();
3136     my $del_lrfetchrefs = sub {
3137         changedir $cwd;
3138         my $gur;
3139         printdebug "del_lrfetchrefs...\n";
3140         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3141             my $objid = $lrfetchrefs_d{$fullrefname};
3142             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3143             if (!$gur) {
3144                 $gur ||= new IO::Handle;
3145                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3146             }
3147             printf $gur "delete %s %s\n", $fullrefname, $objid;
3148         }
3149         if ($gur) {
3150             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3151         }
3152     };
3153
3154     if (defined $dsc_hash) {
3155         ensure_we_have_orig();
3156         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3157             @mergeinputs = $dsc_mergeinput
3158         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3159             print STDERR <<END or die $!;
3160
3161 Git commit in archive is behind the last version allegedly pushed/uploaded.
3162 Commit referred to by archive: $dsc_hash
3163 Last version pushed with dgit: $lastpush_hash
3164 $later_warning_msg
3165 END
3166             @mergeinputs = ($lastpush_mergeinput);
3167         } else {
3168             # Archive has .dsc which is not a descendant of the last dgit
3169             # push.  This can happen if the archive moves .dscs about.
3170             # Just follow its lead.
3171             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3172                 progress "archive .dsc names newer git commit";
3173                 @mergeinputs = ($dsc_mergeinput);
3174             } else {
3175                 progress "archive .dsc names other git commit, fixing up";
3176                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3177             }
3178         }
3179     } elsif ($dsc) {
3180         @mergeinputs = generate_commits_from_dsc();
3181         # We have just done an import.  Now, our import algorithm might
3182         # have been improved.  But even so we do not want to generate
3183         # a new different import of the same package.  So if the
3184         # version numbers are the same, just use our existing version.
3185         # If the version numbers are different, the archive has changed
3186         # (perhaps, rewound).
3187         if ($lastfetch_mergeinput &&
3188             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3189                               (mergeinfo_version $mergeinputs[0]) )) {
3190             @mergeinputs = ($lastfetch_mergeinput);
3191         }
3192     } elsif ($lastpush_hash) {
3193         # only in git, not in the archive yet
3194         @mergeinputs = ($lastpush_mergeinput);
3195         print STDERR <<END or die $!;
3196
3197 Package not found in the archive, but has allegedly been pushed using dgit.
3198 $later_warning_msg
3199 END
3200     } else {
3201         printdebug "nothing found!\n";
3202         if (defined $skew_warning_vsn) {
3203             print STDERR <<END or die $!;
3204
3205 Warning: relevant archive skew detected.
3206 Archive allegedly contains $skew_warning_vsn
3207 But we were not able to obtain any version from the archive or git.
3208
3209 END
3210         }
3211         unshift @end, $del_lrfetchrefs;
3212         return undef;
3213     }
3214
3215     if ($lastfetch_hash &&
3216         !grep {
3217             my $h = $_->{Commit};
3218             $h and is_fast_fwd($lastfetch_hash, $h);
3219             # If true, one of the existing parents of this commit
3220             # is a descendant of the $lastfetch_hash, so we'll
3221             # be ff from that automatically.
3222         } @mergeinputs
3223         ) {
3224         # Otherwise:
3225         push @mergeinputs, $lastfetch_mergeinput;
3226     }
3227
3228     printdebug "fetch mergeinfos:\n";
3229     foreach my $mi (@mergeinputs) {
3230         if ($mi->{Info}) {
3231             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3232         } else {
3233             printdebug sprintf " ReverseParents=%d Message=%s",
3234                 $mi->{ReverseParents}, $mi->{Message};
3235         }
3236     }
3237
3238     my $compat_info= pop @mergeinputs
3239         if $mergeinputs[$#mergeinputs]{Message};
3240
3241     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3242
3243     my $hash;
3244     if (@mergeinputs > 1) {
3245         # here we go, then:
3246         my $tree_commit = $mergeinputs[0]{Commit};
3247
3248         my $tree = get_tree_of_commit $tree_commit;;
3249
3250         # We use the changelog author of the package in question the
3251         # author of this pseudo-merge.  This is (roughly) correct if
3252         # this commit is simply representing aa non-dgit upload.
3253         # (Roughly because it does not record sponsorship - but we
3254         # don't have sponsorship info because that's in the .changes,
3255         # which isn't in the archivw.)
3256         #
3257         # But, it might be that we are representing archive history
3258         # updates (including in-archive copies).  These are not really
3259         # the responsibility of the person who created the .dsc, but
3260         # there is no-one whose name we should better use.  (The
3261         # author of the .dsc-named commit is clearly worse.)
3262
3263         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3264         my $author = clogp_authline $useclogp;
3265         my $cversion = getfield $useclogp, 'Version';
3266
3267         my $mcf = dgit_privdir()."/mergecommit";
3268         open MC, ">", $mcf or die "$mcf $!";
3269         print MC <<END or die $!;
3270 tree $tree
3271 END
3272
3273         my @parents = grep { $_->{Commit} } @mergeinputs;
3274         @parents = reverse @parents if $compat_info->{ReverseParents};
3275         print MC <<END or die $! foreach @parents;
3276 parent $_->{Commit}
3277 END
3278
3279         print MC <<END or die $!;
3280 author $author
3281 committer $author
3282
3283 END
3284
3285         if (defined $compat_info->{Message}) {
3286             print MC $compat_info->{Message} or die $!;
3287         } else {
3288             print MC <<END or die $!;
3289 Record $package ($cversion) in archive suite $csuite
3290
3291 Record that
3292 END
3293             my $message_add_info = sub {
3294                 my ($mi) = (@_);
3295                 my $mversion = mergeinfo_version $mi;
3296                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3297                     or die $!;
3298             };
3299
3300             $message_add_info->($mergeinputs[0]);
3301             print MC <<END or die $!;
3302 should be treated as descended from
3303 END
3304             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3305         }
3306
3307         close MC or die $!;
3308         $hash = make_commit $mcf;
3309     } else {
3310         $hash = $mergeinputs[0]{Commit};
3311     }
3312     printdebug "fetch hash=$hash\n";
3313
3314     my $chkff = sub {
3315         my ($lasth, $what) = @_;
3316         return unless $lasth;
3317         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3318     };
3319
3320     $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3321         if $lastpush_hash;
3322     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3323
3324     fetch_from_archive_record_1($hash);
3325
3326     if (defined $skew_warning_vsn) {
3327         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3328         my $gotclogp = commit_getclogp($hash);
3329         my $got_vsn = getfield $gotclogp, 'Version';
3330         printdebug "SKEW CHECK GOT $got_vsn\n";
3331         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3332             print STDERR <<END or die $!;
3333
3334 Warning: archive skew detected.  Using the available version:
3335 Archive allegedly contains    $skew_warning_vsn
3336 We were able to obtain only   $got_vsn
3337
3338 END
3339         }
3340     }
3341
3342     if ($lastfetch_hash ne $hash) {
3343         fetch_from_archive_record_2($hash);
3344     }
3345
3346     lrfetchref_used lrfetchref();
3347
3348     check_gitattrs($hash, "fetched source tree");
3349
3350     unshift @end, $del_lrfetchrefs;
3351     return $hash;
3352 }
3353
3354 sub set_local_git_config ($$) {
3355     my ($k, $v) = @_;
3356     runcmd @git, qw(config), $k, $v;
3357 }
3358
3359 sub setup_mergechangelogs (;$) {
3360     my ($always) = @_;
3361     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3362
3363     my $driver = 'dpkg-mergechangelogs';
3364     my $cb = "merge.$driver";
3365     confess unless defined $maindir;
3366     my $attrs = "$maindir_gitcommon/info/attributes";
3367     ensuredir "$maindir_gitcommon/info";
3368
3369     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3370     if (!open ATTRS, "<", $attrs) {
3371         $!==ENOENT or die "$attrs: $!";
3372     } else {
3373         while (<ATTRS>) {
3374             chomp;
3375             next if m{^debian/changelog\s};
3376             print NATTRS $_, "\n" or die $!;
3377         }
3378         ATTRS->error and die $!;
3379         close ATTRS;
3380     }
3381     print NATTRS "debian/changelog merge=$driver\n" or die $!;
3382     close NATTRS;
3383
3384     set_local_git_config "$cb.name", 'debian/changelog merge driver';
3385     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3386
3387     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3388 }
3389
3390 sub setup_useremail (;$) {
3391     my ($always) = @_;
3392     return unless $always || access_cfg_bool(1, 'setup-useremail');
3393
3394     my $setup = sub {
3395         my ($k, $envvar) = @_;
3396         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3397         return unless defined $v;
3398         set_local_git_config "user.$k", $v;
3399     };
3400
3401     $setup->('email', 'DEBEMAIL');
3402     $setup->('name', 'DEBFULLNAME');
3403 }
3404
3405 sub ensure_setup_existing_tree () {
3406     my $k = "remote.$remotename.skipdefaultupdate";
3407     my $c = git_get_config $k;
3408     return if defined $c;
3409     set_local_git_config $k, 'true';
3410 }
3411
3412 sub open_main_gitattrs () {
3413     confess 'internal error no maindir' unless defined $maindir;
3414     my $gai = new IO::File "$maindir_gitcommon/info/attributes"
3415         or $!==ENOENT
3416         or die "open $maindir_gitcommon/info/attributes: $!";
3417     return $gai;
3418 }
3419
3420 our $gitattrs_ourmacro_re = qr{^\[attr\]dgit-defuse-attrs\s};
3421
3422 sub is_gitattrs_setup () {
3423     # return values:
3424     #  trueish
3425     #     1: gitattributes set up and should be left alone
3426     #  falseish
3427     #     0: there is a dgit-defuse-attrs but it needs fixing
3428     #     undef: there is none
3429     my $gai = open_main_gitattrs();
3430     return 0 unless $gai;
3431     while (<$gai>) {
3432         next unless m{$gitattrs_ourmacro_re};
3433         return 1 if m{\s-working-tree-encoding\s};
3434         printdebug "is_gitattrs_setup: found old macro\n";
3435         return 0;
3436     }
3437     $gai->error and die $!;
3438     printdebug "is_gitattrs_setup: found nothing\n";
3439     return undef;
3440 }    
3441
3442 sub setup_gitattrs (;$) {
3443     my ($always) = @_;
3444     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3445
3446     my $already = is_gitattrs_setup();
3447     if ($already) {
3448         progress <<END;
3449 [attr]dgit-defuse-attrs already found, and proper, in .git/info/attributes
3450  not doing further gitattributes setup
3451 END
3452         return;
3453     }
3454     my $new = "[attr]dgit-defuse-attrs  $negate_harmful_gitattrs";
3455     my $af = "$maindir_gitcommon/info/attributes";
3456     ensuredir "$maindir_gitcommon/info";
3457
3458     open GAO, "> $af.new" or die $!;
3459     print GAO <<END or die $! unless defined $already;
3460 *       dgit-defuse-attrs
3461 $new
3462 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3463 END
3464     my $gai = open_main_gitattrs();
3465     if ($gai) {
3466         while (<$gai>) {
3467             if (m{$gitattrs_ourmacro_re}) {
3468                 die unless defined $already;
3469                 $_ = $new;
3470             }
3471             chomp;
3472             print GAO $_, "\n" or die $!;
3473         }
3474         $gai->error and die $!;
3475     }
3476     close GAO or die $!;
3477     rename "$af.new", "$af" or die "install $af: $!";
3478 }
3479
3480 sub setup_new_tree () {
3481     setup_mergechangelogs();
3482     setup_useremail();
3483     setup_gitattrs();
3484 }
3485
3486 sub check_gitattrs ($$) {
3487     my ($treeish, $what) = @_;
3488
3489     return if is_gitattrs_setup;
3490
3491     local $/="\0";
3492     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3493     debugcmd "|",@cmd;
3494     my $gafl = new IO::File;
3495     open $gafl, "-|", @cmd or die $!;
3496     while (<$gafl>) {
3497         chomp or die;
3498         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3499         next if $1 == 0;
3500         next unless m{(?:^|/)\.gitattributes$};
3501
3502         # oh dear, found one
3503         print STDERR <<END;
3504 dgit: warning: $what contains .gitattributes
3505 dgit: .gitattributes not (fully) defused.  Recommended: dgit setup-new-tree.
3506 END
3507         close $gafl;
3508         return;
3509     }
3510     # tree contains no .gitattributes files
3511     $?=0; $!=0; close $gafl or failedcmd @cmd;
3512 }
3513
3514
3515 sub multisuite_suite_child ($$$) {
3516     my ($tsuite, $mergeinputs, $fn) = @_;
3517     # in child, sets things up, calls $fn->(), and returns undef
3518     # in parent, returns canonical suite name for $tsuite
3519     my $canonsuitefh = IO::File::new_tmpfile;
3520     my $pid = fork // die $!;
3521     if (!$pid) {
3522         forkcheck_setup();
3523         $isuite = $tsuite;
3524         $us .= " [$isuite]";
3525         $debugprefix .= " ";
3526         progress "fetching $tsuite...";
3527         canonicalise_suite();
3528         print $canonsuitefh $csuite, "\n" or die $!;
3529         close $canonsuitefh or die $!;
3530         $fn->();
3531         return undef;
3532     }
3533     waitpid $pid,0 == $pid or die $!;
3534     fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3535     seek $canonsuitefh,0,0 or die $!;
3536     local $csuite = <$canonsuitefh>;
3537     die $! unless defined $csuite && chomp $csuite;
3538     if ($? == 256*4) {
3539         printdebug "multisuite $tsuite missing\n";
3540         return $csuite;
3541     }
3542     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3543     push @$mergeinputs, {
3544         Ref => lrref,
3545         Info => $csuite,
3546     };
3547     return $csuite;
3548 }
3549
3550 sub fork_for_multisuite ($) {
3551     my ($before_fetch_merge) = @_;
3552     # if nothing unusual, just returns ''
3553     #
3554     # if multisuite:
3555     # returns 0 to caller in child, to do first of the specified suites
3556     # in child, $csuite is not yet set
3557     #
3558     # returns 1 to caller in parent, to finish up anything needed after
3559     # in parent, $csuite is set to canonicalised portmanteau
3560
3561     my $org_isuite = $isuite;
3562     my @suites = split /\,/, $isuite;
3563     return '' unless @suites > 1;
3564     printdebug "fork_for_multisuite: @suites\n";
3565
3566     my @mergeinputs;
3567
3568     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3569                                             sub { });
3570     return 0 unless defined $cbasesuite;
3571
3572     fail "package $package missing in (base suite) $cbasesuite"
3573         unless @mergeinputs;
3574
3575     my @csuites = ($cbasesuite);
3576
3577     $before_fetch_merge->();
3578
3579     foreach my $tsuite (@suites[1..$#suites]) {
3580         $tsuite =~ s/^-/$cbasesuite-/;
3581         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3582                                                sub {
3583             @end = ();
3584             fetch_one();
3585             finish 0;
3586         });
3587
3588         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3589         push @csuites, $csubsuite;
3590     }
3591
3592     foreach my $mi (@mergeinputs) {
3593         my $ref = git_get_ref $mi->{Ref};
3594         die "$mi->{Ref} ?" unless length $ref;
3595         $mi->{Commit} = $ref;
3596     }
3597
3598     $csuite = join ",", @csuites;
3599
3600     my $previous = git_get_ref lrref;
3601     if ($previous) {
3602         unshift @mergeinputs, {
3603             Commit => $previous,
3604             Info => "local combined tracking branch",
3605             Warning =>
3606  "archive seems to have rewound: local tracking branch is ahead!",
3607         };
3608     }
3609
3610     foreach my $ix (0..$#mergeinputs) {
3611         $mergeinputs[$ix]{Index} = $ix;
3612     }
3613
3614     @mergeinputs = sort {
3615         -version_compare(mergeinfo_version $a,
3616                          mergeinfo_version $b) # highest version first
3617             or
3618         $a->{Index} <=> $b->{Index}; # earliest in spec first
3619     } @mergeinputs;
3620
3621     my @needed;
3622
3623   NEEDED:
3624     foreach my $mi (@mergeinputs) {
3625         printdebug "multisuite merge check $mi->{Info}\n";
3626         foreach my $previous (@needed) {
3627             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3628             printdebug "multisuite merge un-needed $previous->{Info}\n";
3629             next NEEDED;
3630         }
3631         push @needed, $mi;
3632         printdebug "multisuite merge this-needed\n";
3633         $mi->{Character} = '+';
3634     }
3635
3636     $needed[0]{Character} = '*';
3637
3638     my $output = $needed[0]{Commit};
3639
3640     if (@needed > 1) {
3641         printdebug "multisuite merge nontrivial\n";
3642         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3643
3644         my $commit = "tree $tree\n";
3645         my $msg = "Combine archive branches $csuite [dgit]\n\n".
3646             "Input branches:\n";
3647
3648         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3649             printdebug "multisuite merge include $mi->{Info}\n";
3650             $mi->{Character} //= ' ';
3651             $commit .= "parent $mi->{Commit}\n";
3652             $msg .= sprintf " %s  %-25s %s\n",
3653                 $mi->{Character},
3654                 (mergeinfo_version $mi),
3655                 $mi->{Info};
3656         }
3657         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3658         $msg .= "\nKey\n".
3659             " * marks the highest version branch, which choose to use\n".
3660             " + marks each branch which was not already an ancestor\n\n".
3661             "[dgit multi-suite $csuite]\n";
3662         $commit .=
3663             "author $authline\n".
3664             "committer $authline\n\n";
3665         $output = make_commit_text $commit.$msg;
3666         printdebug "multisuite merge generated $output\n";
3667     }
3668
3669     fetch_from_archive_record_1($output);
3670     fetch_from_archive_record_2($output);
3671
3672     progress "calculated combined tracking suite $csuite";
3673
3674     return 1;
3675 }
3676
3677 sub clone_set_head () {
3678     open H, "> .git/HEAD" or die $!;
3679     print H "ref: ".lref()."\n" or die $!;
3680     close H or die $!;
3681 }
3682 sub clone_finish ($) {
3683     my ($dstdir) = @_;
3684     runcmd @git, qw(reset --hard), lrref();
3685     runcmd qw(bash -ec), <<'END';
3686         set -o pipefail
3687         git ls-tree -r --name-only -z HEAD | \
3688         xargs -0r touch -h -r . --
3689 END
3690     printdone "ready for work in $dstdir";
3691 }
3692
3693 sub clone ($) {
3694     # in multisuite, returns twice!
3695     # once in parent after first suite fetched,
3696     # and then again in child after everything is finished
3697     my ($dstdir) = @_;
3698     badusage "dry run makes no sense with clone" unless act_local();
3699
3700     my $multi_fetched = fork_for_multisuite(sub {
3701         printdebug "multi clone before fetch merge\n";
3702         changedir $dstdir;
3703