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