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