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