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