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