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