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