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