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