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