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