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