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