chiark / gitweb /
74de9af15461c53551d42c0fbabd1cb476de0002
[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"; pwd; find -atime +30 -type f -print0 | xargs -0r echo 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         print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1895         if (@found_differ && !$found_same) {
1896             fail join "\n",
1897                 "archive contains $file with different checksum",
1898                 @found_differ;
1899         }
1900         # Now we edit the changes file to add or remove it
1901         foreach my $csumi (@files_csum_info_fields) {
1902             my ($fname, $module, $method, $archivefield) = @$csumi;
1903             next unless defined $changes->{$fname};
1904             if ($found_same) {
1905                 # in archive, delete from .changes if it's there
1906                 $changed{$file} = "removed" if
1907                     $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1908             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1909                 # not in archive, but it's here in the .changes
1910             } else {
1911                 my $dsc_data = getfield $dsc, $fname;
1912                 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1913                 my $extra = $1;
1914                 $extra =~ s/ \d+ /$&$placementinfo /
1915                     or die "$fname $extra >$dsc_data< ?"
1916                     if $fname eq 'Files';
1917                 $changes->{$fname} .= "\n". $extra;
1918                 $changed{$file} = "added";
1919             }
1920         }
1921     }
1922     if (%changed) {
1923         foreach my $file (keys %changed) {
1924             progress sprintf
1925                 "edited .changes for archive .orig contents: %s %s",
1926                 $changed{$file}, $file;
1927         }
1928         my $chtmp = "$changesfile.tmp";
1929         $changes->save($chtmp);
1930         if (act_local()) {
1931             rename $chtmp,$changesfile or die "$changesfile $!";
1932         } else {
1933             progress "[new .changes left in $changesfile]";
1934         }
1935     } else {
1936         progress "$changesfile already has appropriate .orig(s) (if any)";
1937     }
1938 }
1939
1940 sub make_commit ($) {
1941     my ($file) = @_;
1942     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1943 }
1944
1945 sub make_commit_text ($) {
1946     my ($text) = @_;
1947     my ($out, $in);
1948     my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1949     debugcmd "|",@cmd;
1950     print Dumper($text) if $debuglevel > 1;
1951     my $child = open2($out, $in, @cmd) or die $!;
1952     my $h;
1953     eval {
1954         print $in $text or die $!;
1955         close $in or die $!;
1956         $h = <$out>;
1957         $h =~ m/^\w+$/ or die;
1958         $h = $&;
1959         printdebug "=> $h\n";
1960     };
1961     close $out;
1962     waitpid $child, 0 == $child or die "$child $!";
1963     $? and failedcmd @cmd;
1964     return $h;
1965 }
1966
1967 sub clogp_authline ($) {
1968     my ($clogp) = @_;
1969     my $author = getfield $clogp, 'Maintainer';
1970     $author =~ s#,.*##ms;
1971     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1972     my $authline = "$author $date";
1973     $authline =~ m/$git_authline_re/o or
1974         fail "unexpected commit author line format \`$authline'".
1975         " (was generated from changelog Maintainer field)";
1976     return ($1,$2,$3) if wantarray;
1977     return $authline;
1978 }
1979
1980 sub vendor_patches_distro ($$) {
1981     my ($checkdistro, $what) = @_;
1982     return unless defined $checkdistro;
1983
1984     my $series = "debian/patches/\L$checkdistro\E.series";
1985     printdebug "checking for vendor-specific $series ($what)\n";
1986
1987     if (!open SERIES, "<", $series) {
1988         die "$series $!" unless $!==ENOENT;
1989         return;
1990     }
1991     while (<SERIES>) {
1992         next unless m/\S/;
1993         next if m/^\s+\#/;
1994
1995         print STDERR <<END;
1996
1997 Unfortunately, this source package uses a feature of dpkg-source where
1998 the same source package unpacks to different source code on different
1999 distros.  dgit cannot safely operate on such packages on affected
2000 distros, because the meaning of source packages is not stable.
2001
2002 Please ask the distro/maintainer to remove the distro-specific series
2003 files and use a different technique (if necessary, uploading actually
2004 different packages, if different distros are supposed to have
2005 different code).
2006
2007 END
2008         fail "Found active distro-specific series file for".
2009             " $checkdistro ($what): $series, cannot continue";
2010     }
2011     die "$series $!" if SERIES->error;
2012     close SERIES;
2013 }
2014
2015 sub check_for_vendor_patches () {
2016     # This dpkg-source feature doesn't seem to be documented anywhere!
2017     # But it can be found in the changelog (reformatted):
2018
2019     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
2020     #   Author: Raphael Hertzog <hertzog@debian.org>
2021     #   Date: Sun  Oct  3  09:36:48  2010 +0200
2022
2023     #   dpkg-source: correctly create .pc/.quilt_series with alternate
2024     #   series files
2025     #   
2026     #   If you have debian/patches/ubuntu.series and you were
2027     #   unpacking the source package on ubuntu, quilt was still
2028     #   directed to debian/patches/series instead of
2029     #   debian/patches/ubuntu.series.
2030     #   
2031     #   debian/changelog                        |    3 +++
2032     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
2033     #   2 files changed, 6 insertions(+), 1 deletion(-)
2034
2035     use Dpkg::Vendor;
2036     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2037     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2038                          "Dpkg::Vendor \`current vendor'");
2039     vendor_patches_distro(access_basedistro(),
2040                           "(base) distro being accessed");
2041     vendor_patches_distro(access_nomdistro(),
2042                           "(nominal) distro being accessed");
2043 }
2044
2045 sub generate_commits_from_dsc () {
2046     # See big comment in fetch_from_archive, below.
2047     # See also README.dsc-import.
2048     prep_ud();
2049     changedir $ud;
2050
2051     my @dfi = dsc_files_info();
2052     foreach my $fi (@dfi) {
2053         my $f = $fi->{Filename};
2054         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2055
2056         printdebug "considering linking $f: ";
2057
2058         link_ltarget "../../../../$f", $f
2059             or ((printdebug "($!) "), 0)
2060             or $!==&ENOENT
2061             or die "$f $!";
2062
2063         printdebug "linked.\n";
2064
2065         complete_file_from_dsc('.', $fi)
2066             or next;
2067
2068         if (is_orig_file_in_dsc($f, \@dfi)) {
2069             link $f, "../../../../$f"
2070                 or $!==&EEXIST
2071                 or die "$f $!";
2072         }
2073     }
2074
2075     # We unpack and record the orig tarballs first, so that we only
2076     # need disk space for one private copy of the unpacked source.
2077     # But we can't make them into commits until we have the metadata
2078     # from the debian/changelog, so we record the tree objects now and
2079     # make them into commits later.
2080     my @tartrees;
2081     my $upstreamv = upstreamversion $dsc->{version};
2082     my $orig_f_base = srcfn $upstreamv, '';
2083
2084     foreach my $fi (@dfi) {
2085         # We actually import, and record as a commit, every tarball
2086         # (unless there is only one file, in which case there seems
2087         # little point.
2088
2089         my $f = $fi->{Filename};
2090         printdebug "import considering $f ";
2091         (printdebug "only one dfi\n"), next if @dfi == 1;
2092         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2093         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2094         my $compr_ext = $1;
2095
2096         my ($orig_f_part) =
2097             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2098
2099         printdebug "Y ", (join ' ', map { $_//"(none)" }
2100                           $compr_ext, $orig_f_part
2101                          ), "\n";
2102
2103         my $input = new IO::File $f, '<' or die "$f $!";
2104         my $compr_pid;
2105         my @compr_cmd;
2106
2107         if (defined $compr_ext) {
2108             my $cname =
2109                 Dpkg::Compression::compression_guess_from_filename $f;
2110             fail "Dpkg::Compression cannot handle file $f in source package"
2111                 if defined $compr_ext && !defined $cname;
2112             my $compr_proc =
2113                 new Dpkg::Compression::Process compression => $cname;
2114             my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2115             my $compr_fh = new IO::Handle;
2116             my $compr_pid = open $compr_fh, "-|" // die $!;
2117             if (!$compr_pid) {
2118                 open STDIN, "<&", $input or die $!;
2119                 exec @compr_cmd;
2120                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2121             }
2122             $input = $compr_fh;
2123         }
2124
2125         rmtree "../unpack-tar";
2126         mkdir "../unpack-tar" or die $!;
2127         my @tarcmd = qw(tar -x -f -
2128                         --no-same-owner --no-same-permissions
2129                         --no-acls --no-xattrs --no-selinux);
2130         my $tar_pid = fork // die $!;
2131         if (!$tar_pid) {
2132             chdir "../unpack-tar" or die $!;
2133             open STDIN, "<&", $input or die $!;
2134             exec @tarcmd;
2135             die "dgit (child): exec $tarcmd[0]: $!";
2136         }
2137         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2138         !$? or failedcmd @tarcmd;
2139
2140         close $input or
2141             (@compr_cmd ? failedcmd @compr_cmd
2142              : die $!);
2143         # finally, we have the results in "tarball", but maybe
2144         # with the wrong permissions
2145
2146         runcmd qw(chmod -R +rwX ../unpack-tar);
2147         changedir "../unpack-tar";
2148         my ($tree) = mktree_in_ud_from_only_subdir(1);
2149         changedir "../../unpack";
2150         rmtree "../unpack-tar";
2151
2152         my $ent = [ $f, $tree ];
2153         push @tartrees, {
2154             Orig => !!$orig_f_part,
2155             Sort => (!$orig_f_part         ? 2 :
2156                      $orig_f_part =~ m/-/g ? 1 :
2157                                              0),
2158             F => $f,
2159             Tree => $tree,
2160         };
2161     }
2162
2163     @tartrees = sort {
2164         # put any without "_" first (spec is not clear whether files
2165         # are always in the usual order).  Tarballs without "_" are
2166         # the main orig or the debian tarball.
2167         $a->{Sort} <=> $b->{Sort} or
2168         $a->{F}    cmp $b->{F}
2169     } @tartrees;
2170
2171     my $any_orig = grep { $_->{Orig} } @tartrees;
2172
2173     my $dscfn = "$package.dsc";
2174
2175     my $treeimporthow = 'package';
2176
2177     open D, ">", $dscfn or die "$dscfn: $!";
2178     print D $dscdata or die "$dscfn: $!";
2179     close D or die "$dscfn: $!";
2180     my @cmd = qw(dpkg-source);
2181     push @cmd, '--no-check' if $dsc_checked;
2182     if (madformat $dsc->{format}) {
2183         push @cmd, '--skip-patches';
2184         $treeimporthow = 'unpatched';
2185     }
2186     push @cmd, qw(-x --), $dscfn;
2187     runcmd @cmd;
2188
2189     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2190     if (madformat $dsc->{format}) { 
2191         check_for_vendor_patches();
2192     }
2193
2194     my $dappliedtree;
2195     if (madformat $dsc->{format}) {
2196         my @pcmd = qw(dpkg-source --before-build .);
2197         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2198         rmtree '.pc';
2199         runcmd @git, qw(add -Af);
2200         $dappliedtree = git_write_tree();
2201     }
2202
2203     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2204     debugcmd "|",@clogcmd;
2205     open CLOGS, "-|", @clogcmd or die $!;
2206
2207     my $clogp;
2208     my $r1clogp;
2209
2210     printdebug "import clog search...\n";
2211
2212     for (;;) {
2213         my $stanzatext = do { local $/=""; <CLOGS>; };
2214         printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2215         last if !defined $stanzatext;
2216
2217         my $desc = "package changelog, entry no.$.";
2218         open my $stanzafh, "<", \$stanzatext or die;
2219         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2220         $clogp //= $thisstanza;
2221
2222         printdebug "import clog $thisstanza->{version} $desc...\n";
2223
2224         last if !$any_orig; # we don't need $r1clogp
2225
2226         # We look for the first (most recent) changelog entry whose
2227         # version number is lower than the upstream version of this
2228         # package.  Then the last (least recent) previous changelog
2229         # entry is treated as the one which introduced this upstream
2230         # version and used for the synthetic commits for the upstream
2231         # tarballs.
2232
2233         # One might think that a more sophisticated algorithm would be
2234         # necessary.  But: we do not want to scan the whole changelog
2235         # file.  Stopping when we see an earlier version, which
2236         # necessarily then is an earlier upstream version, is the only
2237         # realistic way to do that.  Then, either the earliest
2238         # changelog entry we have seen so far is indeed the earliest
2239         # upload of this upstream version; or there are only changelog
2240         # entries relating to later upstream versions (which is not
2241         # possible unless the changelog and .dsc disagree about the
2242         # version).  Then it remains to choose between the physically
2243         # last entry in the file, and the one with the lowest version
2244         # number.  If these are not the same, we guess that the
2245         # versions were created in a non-monotic order rather than
2246         # that the changelog entries have been misordered.
2247
2248         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2249
2250         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2251         $r1clogp = $thisstanza;
2252
2253         printdebug "import clog $r1clogp->{version} becomes r1\n";
2254     }
2255     die $! if CLOGS->error;
2256     close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2257
2258     $clogp or fail "package changelog has no entries!";
2259
2260     my $authline = clogp_authline $clogp;
2261     my $changes = getfield $clogp, 'Changes';
2262     my $cversion = getfield $clogp, 'Version';
2263
2264     if (@tartrees) {
2265         $r1clogp //= $clogp; # maybe there's only one entry;
2266         my $r1authline = clogp_authline $r1clogp;
2267         # Strictly, r1authline might now be wrong if it's going to be
2268         # unused because !$any_orig.  Whatever.
2269
2270         printdebug "import tartrees authline   $authline\n";
2271         printdebug "import tartrees r1authline $r1authline\n";
2272
2273         foreach my $tt (@tartrees) {
2274             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2275
2276             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2277 tree $tt->{Tree}
2278 author $r1authline
2279 committer $r1authline
2280
2281 Import $tt->{F}
2282
2283 [dgit import orig $tt->{F}]
2284 END_O
2285 tree $tt->{Tree}
2286 author $authline
2287 committer $authline
2288
2289 Import $tt->{F}
2290
2291 [dgit import tarball $package $cversion $tt->{F}]
2292 END_T
2293         }
2294     }
2295
2296     printdebug "import main commit\n";
2297
2298     open C, ">../commit.tmp" or die $!;
2299     print C <<END or die $!;
2300 tree $tree
2301 END
2302     print C <<END or die $! foreach @tartrees;
2303 parent $_->{Commit}
2304 END
2305     print C <<END or die $!;
2306 author $authline
2307 committer $authline
2308
2309 $changes
2310
2311 [dgit import $treeimporthow $package $cversion]
2312 END
2313
2314     close C or die $!;
2315     my $rawimport_hash = make_commit qw(../commit.tmp);
2316
2317     if (madformat $dsc->{format}) {
2318         printdebug "import apply patches...\n";
2319
2320         # regularise the state of the working tree so that
2321         # the checkout of $rawimport_hash works nicely.
2322         my $dappliedcommit = make_commit_text(<<END);
2323 tree $dappliedtree
2324 author $authline
2325 committer $authline
2326
2327 [dgit dummy commit]
2328 END
2329         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2330
2331         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2332
2333         # We need the answers to be reproducible
2334         my @authline = clogp_authline($clogp);
2335         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2336         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2337         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2338         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2339         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2340         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2341
2342         my $path = $ENV{PATH} or die;
2343
2344         foreach my $use_absurd (qw(0 1)) {
2345             local $ENV{PATH} = $path;
2346             if ($use_absurd) {
2347                 chomp $@;
2348                 progress "warning: $@";
2349                 $path = "$absurdity:$path";
2350                 progress "$us: trying slow absurd-git-apply...";
2351                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2352                     or $!==ENOENT
2353                     or die $!;
2354             }
2355             eval {
2356                 die "forbid absurd git-apply\n" if $use_absurd
2357                     && forceing [qw(import-gitapply-no-absurd)];
2358                 die "only absurd git-apply!\n" if !$use_absurd
2359                     && forceing [qw(import-gitapply-absurd)];
2360
2361                 local $ENV{PATH} = $path if $use_absurd;
2362
2363                 my @showcmd = (gbp_pq, qw(import));
2364                 my @realcmd = shell_cmd
2365                     'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2366                 debugcmd "+",@realcmd;
2367                 if (system @realcmd) {
2368                     die +(shellquote @showcmd).
2369                         " failed: ".
2370                         failedcmd_waitstatus()."\n";
2371                 }
2372
2373                 my $gapplied = git_rev_parse('HEAD');
2374                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2375                 $gappliedtree eq $dappliedtree or
2376                     fail <<END;
2377 gbp-pq import and dpkg-source disagree!
2378  gbp-pq import gave commit $gapplied
2379  gbp-pq import gave tree $gappliedtree
2380  dpkg-source --before-build gave tree $dappliedtree
2381 END
2382                 $rawimport_hash = $gapplied;
2383             };
2384             last unless $@;
2385         }
2386         if ($@) {
2387             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2388             die $@;
2389         }
2390     }
2391
2392     progress "synthesised git commit from .dsc $cversion";
2393
2394     my $rawimport_mergeinput = {
2395         Commit => $rawimport_hash,
2396         Info => "Import of source package",
2397     };
2398     my @output = ($rawimport_mergeinput);
2399
2400     if ($lastpush_mergeinput) {
2401         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2402         my $oversion = getfield $oldclogp, 'Version';
2403         my $vcmp =
2404             version_compare($oversion, $cversion);
2405         if ($vcmp < 0) {
2406             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2407                 { Message => <<END, ReverseParents => 1 });
2408 Record $package ($cversion) in archive suite $csuite
2409 END
2410         } elsif ($vcmp > 0) {
2411             print STDERR <<END or die $!;
2412
2413 Version actually in archive:   $cversion (older)
2414 Last version pushed with dgit: $oversion (newer or same)
2415 $later_warning_msg
2416 END
2417             @output = $lastpush_mergeinput;
2418         } else {
2419             # Same version.  Use what's in the server git branch,
2420             # discarding our own import.  (This could happen if the
2421             # server automatically imports all packages into git.)
2422             @output = $lastpush_mergeinput;
2423         }
2424     }
2425     changedir '../../../..';
2426     rmtree($ud);
2427     return @output;
2428 }
2429
2430 sub complete_file_from_dsc ($$) {
2431     our ($dstdir, $fi) = @_;
2432     # Ensures that we have, in $dir, the file $fi, with the correct
2433     # contents.  (Downloading it from alongside $dscurl if necessary.)
2434
2435     my $f = $fi->{Filename};
2436     my $tf = "$dstdir/$f";
2437     my $downloaded = 0;
2438
2439     if (stat_exists $tf) {
2440         progress "using existing $f";
2441     } else {
2442         printdebug "$tf does not exist, need to fetch\n";
2443         my $furl = $dscurl;
2444         $furl =~ s{/[^/]+$}{};
2445         $furl .= "/$f";
2446         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2447         die "$f ?" if $f =~ m#/#;
2448         runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2449         return 0 if !act_local();
2450         $downloaded = 1;
2451     }
2452
2453     open F, "<", "$tf" or die "$tf: $!";
2454     $fi->{Digester}->reset();
2455     $fi->{Digester}->addfile(*F);
2456     F->error and die $!;
2457     my $got = $fi->{Digester}->hexdigest();
2458     $got eq $fi->{Hash} or
2459         fail "file $f has hash $got but .dsc".
2460             " demands hash $fi->{Hash} ".
2461             ($downloaded ? "(got wrong file from archive!)"
2462              : "(perhaps you should delete this file?)");
2463
2464     return 1;
2465 }
2466
2467 sub ensure_we_have_orig () {
2468     my @dfi = dsc_files_info();
2469     foreach my $fi (@dfi) {
2470         my $f = $fi->{Filename};
2471         next unless is_orig_file_in_dsc($f, \@dfi);
2472         complete_file_from_dsc('..', $fi)
2473             or next;
2474     }
2475 }
2476
2477 sub git_fetch_us () {
2478     # Want to fetch only what we are going to use, unless
2479     # deliberately-not-ff, in which case we must fetch everything.
2480
2481     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2482         map { "tags/$_" }
2483         (quiltmode_splitbrain
2484          ? (map { $_->('*',access_nomdistro) }
2485             \&debiantag_new, \&debiantag_maintview)
2486          : debiantags('*',access_nomdistro));
2487     push @specs, server_branch($csuite);
2488     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2489
2490     # This is rather miserable:
2491     # When git fetch --prune is passed a fetchspec ending with a *,
2492     # it does a plausible thing.  If there is no * then:
2493     # - it matches subpaths too, even if the supplied refspec
2494     #   starts refs, and behaves completely madly if the source
2495     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2496     # - if there is no matching remote ref, it bombs out the whole
2497     #   fetch.
2498     # We want to fetch a fixed ref, and we don't know in advance
2499     # if it exists, so this is not suitable.
2500     #
2501     # Our workaround is to use git ls-remote.  git ls-remote has its
2502     # own qairks.  Notably, it has the absurd multi-tail-matching
2503     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2504     # refs/refs/foo etc.
2505     #
2506     # Also, we want an idempotent snapshot, but we have to make two
2507     # calls to the remote: one to git ls-remote and to git fetch.  The
2508     # solution is use git ls-remote to obtain a target state, and
2509     # git fetch to try to generate it.  If we don't manage to generate
2510     # the target state, we try again.
2511
2512     printdebug "git_fetch_us specs @specs\n";
2513
2514     my $specre = join '|', map {
2515         my $x = $_;
2516         $x =~ s/\W/\\$&/g;
2517         $x =~ s/\\\*$/.*/;
2518         "(?:refs/$x)";
2519     } @specs;
2520     printdebug "git_fetch_us specre=$specre\n";
2521     my $wanted_rref = sub {
2522         local ($_) = @_;
2523         return m/^(?:$specre)$/o;
2524     };
2525
2526     my $fetch_iteration = 0;
2527     FETCH_ITERATION:
2528     for (;;) {
2529         printdebug "git_fetch_us iteration $fetch_iteration\n";
2530         if (++$fetch_iteration > 10) {
2531             fail "too many iterations trying to get sane fetch!";
2532         }
2533
2534         my @look = map { "refs/$_" } @specs;
2535         my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2536         debugcmd "|",@lcmd;
2537
2538         my %wantr;
2539         open GITLS, "-|", @lcmd or die $!;
2540         while (<GITLS>) {
2541             printdebug "=> ", $_;
2542             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2543             my ($objid,$rrefname) = ($1,$2);
2544             if (!$wanted_rref->($rrefname)) {
2545                 print STDERR <<END;
2546 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2547 END
2548                 next;
2549             }
2550             $wantr{$rrefname} = $objid;
2551         }
2552         $!=0; $?=0;
2553         close GITLS or failedcmd @lcmd;
2554
2555         # OK, now %want is exactly what we want for refs in @specs
2556         my @fspecs = map {
2557             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2558             "+refs/$_:".lrfetchrefs."/$_";
2559         } @specs;
2560
2561         printdebug "git_fetch_us fspecs @fspecs\n";
2562
2563         my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2564         runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2565             @fspecs;
2566
2567         %lrfetchrefs_f = ();
2568         my %objgot;
2569
2570         git_for_each_ref(lrfetchrefs, sub {
2571             my ($objid,$objtype,$lrefname,$reftail) = @_;
2572             $lrfetchrefs_f{$lrefname} = $objid;
2573             $objgot{$objid} = 1;
2574         });
2575
2576         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2577             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2578             if (!exists $wantr{$rrefname}) {
2579                 if ($wanted_rref->($rrefname)) {
2580                     printdebug <<END;
2581 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2582 END
2583                 } else {
2584                     print STDERR <<END
2585 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2586 END
2587                 }
2588                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2589                 delete $lrfetchrefs_f{$lrefname};
2590                 next;
2591             }
2592         }
2593         foreach my $rrefname (sort keys %wantr) {
2594             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2595             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2596             my $want = $wantr{$rrefname};
2597             next if $got eq $want;
2598             if (!defined $objgot{$want}) {
2599                 print STDERR <<END;
2600 warning: git ls-remote suggests we want $lrefname
2601 warning:  and it should refer to $want
2602 warning:  but git fetch didn't fetch that object to any relevant ref.
2603 warning:  This may be due to a race with someone updating the server.
2604 warning:  Will try again...
2605 END
2606                 next FETCH_ITERATION;
2607             }
2608             printdebug <<END;
2609 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2610 END
2611             runcmd_ordryrun_local @git, qw(update-ref -m),
2612                 "dgit fetch git fetch fixup", $lrefname, $want;
2613             $lrfetchrefs_f{$lrefname} = $want;
2614         }
2615         last;
2616     }
2617     printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2618         Dumper(\%lrfetchrefs_f);
2619
2620     my %here;
2621     my @tagpats = debiantags('*',access_nomdistro);
2622
2623     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2624         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2625         printdebug "currently $fullrefname=$objid\n";
2626         $here{$fullrefname} = $objid;
2627     });
2628     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2629         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2630         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2631         printdebug "offered $lref=$objid\n";
2632         if (!defined $here{$lref}) {
2633             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2634             runcmd_ordryrun_local @upd;
2635             lrfetchref_used $fullrefname;
2636         } elsif ($here{$lref} eq $objid) {
2637             lrfetchref_used $fullrefname;
2638         } else {
2639             print STDERR \
2640                 "Not updateting $lref from $here{$lref} to $objid.\n";
2641         }
2642     });
2643 }
2644
2645 sub mergeinfo_getclogp ($) {
2646     # Ensures thit $mi->{Clogp} exists and returns it
2647     my ($mi) = @_;
2648     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2649 }
2650
2651 sub mergeinfo_version ($) {
2652     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2653 }
2654
2655 sub fetch_from_archive_record_1 ($) {
2656     my ($hash) = @_;
2657     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2658             'DGIT_ARCHIVE', $hash;
2659     cmdoutput @git, qw(log -n2), $hash;
2660     # ... gives git a chance to complain if our commit is malformed
2661 }
2662
2663 sub fetch_from_archive_record_2 ($) {
2664     my ($hash) = @_;
2665     my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2666     if (act_local()) {
2667         cmdoutput @upd_cmd;
2668     } else {
2669         dryrun_report @upd_cmd;
2670     }
2671 }
2672
2673 sub fetch_from_archive () {
2674     ensure_setup_existing_tree();
2675
2676     # Ensures that lrref() is what is actually in the archive, one way
2677     # or another, according to us - ie this client's
2678     # appropritaely-updated archive view.  Also returns the commit id.
2679     # If there is nothing in the archive, leaves lrref alone and
2680     # returns undef.  git_fetch_us must have already been called.
2681     get_archive_dsc();
2682
2683     if ($dsc) {
2684         foreach my $field (@ourdscfield) {
2685             $dsc_hash = $dsc->{$field};
2686             last if defined $dsc_hash;
2687         }
2688         if (defined $dsc_hash) {
2689             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2690             $dsc_hash = $&;
2691             progress "last upload to archive specified git hash";
2692         } else {
2693             progress "last upload to archive has NO git hash";
2694         }
2695     } else {
2696         progress "no version available from the archive";
2697     }
2698
2699     # If the archive's .dsc has a Dgit field, there are three
2700     # relevant git commitids we need to choose between and/or merge
2701     # together:
2702     #   1. $dsc_hash: the Dgit field from the archive
2703     #   2. $lastpush_hash: the suite branch on the dgit git server
2704     #   3. $lastfetch_hash: our local tracking brach for the suite
2705     #
2706     # These may all be distinct and need not be in any fast forward
2707     # relationship:
2708     #
2709     # If the dsc was pushed to this suite, then the server suite
2710     # branch will have been updated; but it might have been pushed to
2711     # a different suite and copied by the archive.  Conversely a more
2712     # recent version may have been pushed with dgit but not appeared
2713     # in the archive (yet).
2714     #
2715     # $lastfetch_hash may be awkward because archive imports
2716     # (particularly, imports of Dgit-less .dscs) are performed only as
2717     # needed on individual clients, so different clients may perform a
2718     # different subset of them - and these imports are only made
2719     # public during push.  So $lastfetch_hash may represent a set of
2720     # imports different to a subsequent upload by a different dgit
2721     # client.
2722     #
2723     # Our approach is as follows:
2724     #
2725     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2726     # descendant of $dsc_hash, then it was pushed by a dgit user who
2727     # had based their work on $dsc_hash, so we should prefer it.
2728     # Otherwise, $dsc_hash was installed into this suite in the
2729     # archive other than by a dgit push, and (necessarily) after the
2730     # last dgit push into that suite (since a dgit push would have
2731     # been descended from the dgit server git branch); thus, in that
2732     # case, we prefer the archive's version (and produce a
2733     # pseudo-merge to overwrite the dgit server git branch).
2734     #
2735     # (If there is no Dgit field in the archive's .dsc then
2736     # generate_commit_from_dsc uses the version numbers to decide
2737     # whether the suite branch or the archive is newer.  If the suite
2738     # branch is newer it ignores the archive's .dsc; otherwise it
2739     # generates an import of the .dsc, and produces a pseudo-merge to
2740     # overwrite the suite branch with the archive contents.)
2741     #
2742     # The outcome of that part of the algorithm is the `public view',
2743     # and is same for all dgit clients: it does not depend on any
2744     # unpublished history in the local tracking branch.
2745     #
2746     # As between the public view and the local tracking branch: The
2747     # local tracking branch is only updated by dgit fetch, and
2748     # whenever dgit fetch runs it includes the public view in the
2749     # local tracking branch.  Therefore if the public view is not
2750     # descended from the local tracking branch, the local tracking
2751     # branch must contain history which was imported from the archive
2752     # but never pushed; and, its tip is now out of date.  So, we make
2753     # a pseudo-merge to overwrite the old imports and stitch the old
2754     # history in.
2755     #
2756     # Finally: we do not necessarily reify the public view (as
2757     # described above).  This is so that we do not end up stacking two
2758     # pseudo-merges.  So what we actually do is figure out the inputs
2759     # to any public view pseudo-merge and put them in @mergeinputs.
2760
2761     my @mergeinputs;
2762     # $mergeinputs[]{Commit}
2763     # $mergeinputs[]{Info}
2764     # $mergeinputs[0] is the one whose tree we use
2765     # @mergeinputs is in the order we use in the actual commit)
2766     #
2767     # Also:
2768     # $mergeinputs[]{Message} is a commit message to use
2769     # $mergeinputs[]{ReverseParents} if def specifies that parent
2770     #                                list should be in opposite order
2771     # Such an entry has no Commit or Info.  It applies only when found
2772     # in the last entry.  (This ugliness is to support making
2773     # identical imports to previous dgit versions.)
2774
2775     my $lastpush_hash = git_get_ref(lrfetchref());
2776     printdebug "previous reference hash=$lastpush_hash\n";
2777     $lastpush_mergeinput = $lastpush_hash && {
2778         Commit => $lastpush_hash,
2779         Info => "dgit suite branch on dgit git server",
2780     };
2781
2782     my $lastfetch_hash = git_get_ref(lrref());
2783     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2784     my $lastfetch_mergeinput = $lastfetch_hash && {
2785         Commit => $lastfetch_hash,
2786         Info => "dgit client's archive history view",
2787     };
2788
2789     my $dsc_mergeinput = $dsc_hash && {
2790         Commit => $dsc_hash,
2791         Info => "Dgit field in .dsc from archive",
2792     };
2793
2794     my $cwd = getcwd();
2795     my $del_lrfetchrefs = sub {
2796         changedir $cwd;
2797         my $gur;
2798         printdebug "del_lrfetchrefs...\n";
2799         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2800             my $objid = $lrfetchrefs_d{$fullrefname};
2801             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2802             if (!$gur) {
2803                 $gur ||= new IO::Handle;
2804                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2805             }
2806             printf $gur "delete %s %s\n", $fullrefname, $objid;
2807         }
2808         if ($gur) {
2809             close $gur or failedcmd "git update-ref delete lrfetchrefs";
2810         }
2811     };
2812
2813     if (defined $dsc_hash) {
2814         ensure_we_have_orig();
2815         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2816             @mergeinputs = $dsc_mergeinput
2817         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2818             print STDERR <<END or die $!;
2819
2820 Git commit in archive is behind the last version allegedly pushed/uploaded.
2821 Commit referred to by archive: $dsc_hash
2822 Last version pushed with dgit: $lastpush_hash
2823 $later_warning_msg
2824 END
2825             @mergeinputs = ($lastpush_mergeinput);
2826         } else {
2827             # Archive has .dsc which is not a descendant of the last dgit
2828             # push.  This can happen if the archive moves .dscs about.
2829             # Just follow its lead.
2830             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2831                 progress "archive .dsc names newer git commit";
2832                 @mergeinputs = ($dsc_mergeinput);
2833             } else {
2834                 progress "archive .dsc names other git commit, fixing up";
2835                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2836             }
2837         }
2838     } elsif ($dsc) {
2839         @mergeinputs = generate_commits_from_dsc();
2840         # We have just done an import.  Now, our import algorithm might
2841         # have been improved.  But even so we do not want to generate
2842         # a new different import of the same package.  So if the
2843         # version numbers are the same, just use our existing version.
2844         # If the version numbers are different, the archive has changed
2845         # (perhaps, rewound).
2846         if ($lastfetch_mergeinput &&
2847             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2848                               (mergeinfo_version $mergeinputs[0]) )) {
2849             @mergeinputs = ($lastfetch_mergeinput);
2850         }
2851     } elsif ($lastpush_hash) {
2852         # only in git, not in the archive yet
2853         @mergeinputs = ($lastpush_mergeinput);
2854         print STDERR <<END or die $!;
2855
2856 Package not found in the archive, but has allegedly been pushed using dgit.
2857 $later_warning_msg
2858 END
2859     } else {
2860         printdebug "nothing found!\n";
2861         if (defined $skew_warning_vsn) {
2862             print STDERR <<END or die $!;
2863
2864 Warning: relevant archive skew detected.
2865 Archive allegedly contains $skew_warning_vsn
2866 But we were not able to obtain any version from the archive or git.
2867
2868 END
2869         }
2870         unshift @end, $del_lrfetchrefs;
2871         return undef;
2872     }
2873
2874     if ($lastfetch_hash &&
2875         !grep {
2876             my $h = $_->{Commit};
2877             $h and is_fast_fwd($lastfetch_hash, $h);
2878             # If true, one of the existing parents of this commit
2879             # is a descendant of the $lastfetch_hash, so we'll
2880             # be ff from that automatically.
2881         } @mergeinputs
2882         ) {
2883         # Otherwise:
2884         push @mergeinputs, $lastfetch_mergeinput;
2885     }
2886
2887     printdebug "fetch mergeinfos:\n";
2888     foreach my $mi (@mergeinputs) {
2889         if ($mi->{Info}) {
2890             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2891         } else {
2892             printdebug sprintf " ReverseParents=%d Message=%s",
2893                 $mi->{ReverseParents}, $mi->{Message};
2894         }
2895     }
2896
2897     my $compat_info= pop @mergeinputs
2898         if $mergeinputs[$#mergeinputs]{Message};
2899
2900     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2901
2902     my $hash;
2903     if (@mergeinputs > 1) {
2904         # here we go, then:
2905         my $tree_commit = $mergeinputs[0]{Commit};
2906
2907         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2908         $tree =~ m/\n\n/;  $tree = $`;
2909         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2910         $tree = $1;
2911
2912         # We use the changelog author of the package in question the
2913         # author of this pseudo-merge.  This is (roughly) correct if
2914         # this commit is simply representing aa non-dgit upload.
2915         # (Roughly because it does not record sponsorship - but we
2916         # don't have sponsorship info because that's in the .changes,
2917         # which isn't in the archivw.)
2918         #
2919         # But, it might be that we are representing archive history
2920         # updates (including in-archive copies).  These are not really
2921         # the responsibility of the person who created the .dsc, but
2922         # there is no-one whose name we should better use.  (The
2923         # author of the .dsc-named commit is clearly worse.)
2924
2925         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2926         my $author = clogp_authline $useclogp;
2927         my $cversion = getfield $useclogp, 'Version';
2928
2929         my $mcf = ".git/dgit/mergecommit";
2930         open MC, ">", $mcf or die "$mcf $!";
2931         print MC <<END or die $!;
2932 tree $tree
2933 END
2934
2935         my @parents = grep { $_->{Commit} } @mergeinputs;
2936         @parents = reverse @parents if $compat_info->{ReverseParents};
2937         print MC <<END or die $! foreach @parents;
2938 parent $_->{Commit}
2939 END
2940
2941         print MC <<END or die $!;
2942 author $author
2943 committer $author
2944
2945 END
2946
2947         if (defined $compat_info->{Message}) {
2948             print MC $compat_info->{Message} or die $!;
2949         } else {
2950             print MC <<END or die $!;
2951 Record $package ($cversion) in archive suite $csuite
2952
2953 Record that
2954 END
2955             my $message_add_info = sub {
2956                 my ($mi) = (@_);
2957                 my $mversion = mergeinfo_version $mi;
2958                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2959                     or die $!;
2960             };
2961
2962             $message_add_info->($mergeinputs[0]);
2963             print MC <<END or die $!;
2964 should be treated as descended from
2965 END
2966             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2967         }
2968
2969         close MC or die $!;
2970         $hash = make_commit $mcf;
2971     } else {
2972         $hash = $mergeinputs[0]{Commit};
2973     }
2974     printdebug "fetch hash=$hash\n";
2975
2976     my $chkff = sub {
2977         my ($lasth, $what) = @_;
2978         return unless $lasth;
2979         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2980     };
2981
2982     $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2983         if $lastpush_hash;
2984     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2985
2986     fetch_from_archive_record_1($hash);
2987
2988     if (defined $skew_warning_vsn) {
2989         mkpath '.git/dgit';
2990         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2991         my $gotclogp = commit_getclogp($hash);
2992         my $got_vsn = getfield $gotclogp, 'Version';
2993         printdebug "SKEW CHECK GOT $got_vsn\n";
2994         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2995             print STDERR <<END or die $!;
2996
2997 Warning: archive skew detected.  Using the available version:
2998 Archive allegedly contains    $skew_warning_vsn
2999 We were able to obtain only   $got_vsn
3000
3001 END
3002         }
3003     }
3004
3005     if ($lastfetch_hash ne $hash) {
3006         fetch_from_archive_record_2($hash);
3007     }
3008
3009     lrfetchref_used lrfetchref();
3010
3011     unshift @end, $del_lrfetchrefs;
3012     return $hash;
3013 }
3014
3015 sub set_local_git_config ($$) {
3016     my ($k, $v) = @_;
3017     runcmd @git, qw(config), $k, $v;
3018 }
3019
3020 sub setup_mergechangelogs (;$) {
3021     my ($always) = @_;
3022     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3023
3024     my $driver = 'dpkg-mergechangelogs';
3025     my $cb = "merge.$driver";
3026     my $attrs = '.git/info/attributes';
3027     ensuredir '.git/info';
3028
3029     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3030     if (!open ATTRS, "<", $attrs) {
3031         $!==ENOENT or die "$attrs: $!";
3032     } else {
3033         while (<ATTRS>) {
3034             chomp;
3035             next if m{^debian/changelog\s};
3036             print NATTRS $_, "\n" or die $!;
3037         }
3038         ATTRS->error and die $!;
3039         close ATTRS;
3040     }
3041     print NATTRS "debian/changelog merge=$driver\n" or die $!;
3042     close NATTRS;
3043
3044     set_local_git_config "$cb.name", 'debian/changelog merge driver';
3045     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3046
3047     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3048 }
3049
3050 sub setup_useremail (;$) {
3051     my ($always) = @_;
3052     return unless $always || access_cfg_bool(1, 'setup-useremail');
3053
3054     my $setup = sub {
3055         my ($k, $envvar) = @_;
3056         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3057         return unless defined $v;
3058         set_local_git_config "user.$k", $v;
3059     };
3060
3061     $setup->('email', 'DEBEMAIL');
3062     $setup->('name', 'DEBFULLNAME');
3063 }
3064
3065 sub ensure_setup_existing_tree () {
3066     my $k = "remote.$remotename.skipdefaultupdate";
3067     my $c = git_get_config $k;
3068     return if defined $c;
3069     set_local_git_config $k, 'true';
3070 }
3071
3072 sub setup_new_tree () {
3073     setup_mergechangelogs();
3074     setup_useremail();
3075 }
3076
3077 sub multisuite_suite_child ($$$) {
3078     my ($tsuite, $merginputs, $fn) = @_;
3079     # in child, sets things up, calls $fn->(), and returns undef
3080     # in parent, returns canonical suite name for $tsuite
3081     my $canonsuitefh = IO::File::new_tmpfile;
3082     my $pid = fork // die $!;
3083     if (!$pid) {
3084         $isuite = $tsuite;
3085         $us .= " [$isuite]";
3086         $debugprefix .= " ";
3087         progress "fetching $tsuite...";
3088         canonicalise_suite();
3089         print $canonsuitefh $csuite, "\n" or die $!;
3090         close $canonsuitefh or die $!;
3091         $fn->();
3092         return undef;
3093     }
3094     waitpid $pid,0 == $pid or die $!;
3095     fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3096     seek $canonsuitefh,0,0 or die $!;
3097     local $csuite = <$canonsuitefh>;
3098     die $! unless defined $csuite && chomp $csuite;
3099     if ($? == 256*4) {
3100         printdebug "multisuite $tsuite missing\n";
3101         return $csuite;
3102     }
3103     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3104     push @$merginputs, {
3105         Ref => lrref,
3106         Info => $csuite,
3107     };
3108     return $csuite;
3109 }
3110
3111 sub fork_for_multisuite ($) {
3112     my ($before_fetch_merge) = @_;
3113     # if nothing unusual, just returns ''
3114     #
3115     # if multisuite:
3116     # returns 0 to caller in child, to do first of the specified suites
3117     # in child, $csuite is not yet set
3118     #
3119     # returns 1 to caller in parent, to finish up anything needed after
3120     # in parent, $csuite is set to canonicalised portmanteau
3121
3122     my $org_isuite = $isuite;
3123     my @suites = split /\,/, $isuite;
3124     return '' unless @suites > 1;
3125     printdebug "fork_for_multisuite: @suites\n";
3126
3127     my @mergeinputs;
3128
3129     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3130                                             sub { });
3131     return 0 unless defined $cbasesuite;
3132
3133     fail "package $package missing in (base suite) $cbasesuite"
3134         unless @mergeinputs;
3135
3136     my @csuites = ($cbasesuite);
3137
3138     $before_fetch_merge->();
3139
3140     foreach my $tsuite (@suites[1..$#suites]) {
3141         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3142                                                sub {
3143             @end = ();
3144             fetch();
3145             exit 0;
3146         });
3147         # xxx collecte the ref here
3148
3149         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3150         push @csuites, $csubsuite;
3151     }
3152
3153     foreach my $mi (@mergeinputs) {
3154         my $ref = git_get_ref $mi->{Ref};
3155         die "$mi->{Ref} ?" unless length $ref;
3156         $mi->{Commit} = $ref;
3157     }
3158
3159     $csuite = join ",", @csuites;
3160
3161     my $previous = git_get_ref lrref;
3162     if ($previous) {
3163         unshift @mergeinputs, {
3164             Commit => $previous,
3165             Info => "local combined tracking branch",
3166             Warning =>
3167  "archive seems to have rewound: local tracking branch is ahead!",
3168         };
3169     }
3170
3171     foreach my $ix (0..$#mergeinputs) {
3172         $mergeinputs[$ix]{Index} = $ix;
3173     }
3174
3175     @mergeinputs = sort {
3176         -version_compare(mergeinfo_version $a,
3177                          mergeinfo_version $b) # highest version first
3178             or
3179         $a->{Index} <=> $b->{Index}; # earliest in spec first
3180     } @mergeinputs;
3181
3182     my @needed;
3183
3184   NEEDED:
3185     foreach my $mi (@mergeinputs) {
3186         printdebug "multisuite merge check $mi->{Info}\n";
3187         foreach my $previous (@needed) {
3188             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3189             printdebug "multisuite merge un-needed $previous->{Info}\n";
3190             next NEEDED;
3191         }
3192         push @needed, $mi;
3193         printdebug "multisuite merge this-needed\n";
3194         $mi->{Character} = '+';
3195     }
3196
3197     $needed[0]{Character} = '*';
3198
3199     my $output = $needed[0]{Commit};
3200
3201     if (@needed > 1) {
3202         printdebug "multisuite merge nontrivial\n";
3203         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3204
3205         my $commit = "tree $tree\n";
3206         my $msg = "Combine archive branches $csuite [dgit]\n\n".
3207             "Input branches:\n";
3208
3209         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3210             printdebug "multisuite merge include $mi->{Info}\n";
3211             $mi->{Character} //= ' ';
3212             $commit .= "parent $mi->{Commit}\n";
3213             $msg .= sprintf " %s  %-25s %s\n",
3214                 $mi->{Character},
3215                 (mergeinfo_version $mi),
3216                 $mi->{Info};
3217         }
3218         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3219         $msg .= "\nKey\n".
3220             " * marks the highest version branch, which choose to use\n".
3221             " + marks each branch which was not already an ancestor\n\n".
3222             "[dgit multi-suite $csuite]\n";
3223         $commit .=
3224             "author $authline\n".
3225             "committer $authline\n\n";
3226         $output = make_commit_text $commit.$msg;
3227         printdebug "multisuite merge generated $output\n";
3228     }
3229
3230     fetch_from_archive_record_1($output);
3231     fetch_from_archive_record_2($output);
3232
3233     progress "calculated combined tracking suite $csuite";
3234
3235     return 1;
3236 }
3237
3238 sub clone_set_head () {
3239     open H, "> .git/HEAD" or die $!;
3240     print H "ref: ".lref()."\n" or die $!;
3241     close H or die $!;
3242 }
3243 sub clone_finish ($) {
3244     my ($dstdir) = @_;
3245     runcmd @git, qw(reset --hard), lrref();
3246     runcmd qw(bash -ec), <<'END';
3247         set -o pipefail
3248         git ls-tree -r --name-only -z HEAD | \
3249         xargs -0r touch -r . --
3250 END
3251     printdone "ready for work in $dstdir";
3252 }
3253
3254 sub clone ($) {
3255     my ($dstdir) = @_;
3256     badusage "dry run makes no sense with clone" unless act_local();
3257
3258     my $multi_fetched = fork_for_multisuite(sub {
3259         printdebug "multi clone before fetch merge\n";
3260         changedir $dstdir;
3261     });
3262     if ($multi_fetched) {
3263         printdebug "multi clone after fetch merge\n";
3264         clone_set_head();
3265         clone_finish($dstdir);
3266         exit 0;
3267     }
3268     printdebug "clone main body\n";
3269
3270     canonicalise_suite();
3271     my $hasgit = check_for_git();
3272     mkdir $dstdir or fail "create \`$dstdir': $!";
3273     changedir $dstdir;
3274     runcmd @git, qw(init -q);
3275     clone_set_head();
3276     my $giturl = access_giturl(1);
3277     if (defined $giturl) {
3278         runcmd @git, qw(remote add), 'origin', $giturl;
3279     }
3280     if ($hasgit) {
3281         progress "fetching existing git history";
3282         git_fetch_us();
3283         runcmd_ordryrun_local @git, qw(fetch origin);
3284     } else {
3285         progress "starting new git history";
3286     }
3287     fetch_from_archive() or no_such_package;
3288     my $vcsgiturl = $dsc->{'Vcs-Git'};
3289     if (length $vcsgiturl) {
3290         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3291         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3292     }
3293     setup_new_tree();
3294     clone_finish($dstdir);
3295 }
3296
3297 sub fetch () {
3298     canonicalise_suite();
3299     if (check_for_git()) {
3300         git_fetch_us();
3301     }
3302     fetch_from_archive() or no_such_package();
3303     printdone "fetched into ".lrref();
3304 }
3305
3306 sub pull () {
3307     my $multi_fetched = fork_for_multisuite(sub { });
3308     fetch() unless $multi_fetched; # parent
3309     return if $multi_fetched eq '0'; # child
3310     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3311         lrref();
3312     printdone "fetched to ".lrref()." and merged into HEAD";
3313 }
3314
3315 sub check_not_dirty () {
3316     foreach my $f (qw(local-options local-patch-header)) {
3317         if (stat_exists "debian/source/$f") {
3318             fail "git tree contains debian/source/$f";
3319         }
3320     }
3321
3322     return if $ignoredirty;
3323
3324     my @cmd = (@git, qw(diff --quiet HEAD));
3325     debugcmd "+",@cmd;
3326     $!=0; $?=-1; system @cmd;
3327     return if !$?;
3328     if ($?==256) {
3329         fail "working tree is dirty (does not match HEAD)";
3330     } else {
3331         failedcmd @cmd;
3332     }
3333 }
3334
3335 sub commit_admin ($) {
3336     my ($m) = @_;
3337     progress "$m";
3338     runcmd_ordryrun_local @git, qw(commit -m), $m;
3339 }
3340
3341 sub commit_quilty_patch () {
3342     my $output = cmdoutput @git, qw(status --porcelain);
3343     my %adds;
3344     foreach my $l (split /\n/, $output) {
3345         next unless $l =~ m/\S/;
3346         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3347             $adds{$1}++;
3348         }
3349     }
3350     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3351     if (!%adds) {
3352         progress "nothing quilty to commit, ok.";
3353         return;
3354     }
3355     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3356     runcmd_ordryrun_local @git, qw(add -f), @adds;
3357     commit_admin <<END
3358 Commit Debian 3.0 (quilt) metadata
3359
3360 [dgit ($our_version) quilt-fixup]
3361 END
3362 }
3363
3364 sub get_source_format () {
3365     my %options;
3366     if (open F, "debian/source/options") {
3367         while (<F>) {
3368             next if m/^\s*\#/;
3369             next unless m/\S/;
3370             s/\s+$//; # ignore missing final newline
3371             if (m/\s*\#\s*/) {
3372                 my ($k, $v) = ($`, $'); #');
3373                 $v =~ s/^"(.*)"$/$1/;
3374                 $options{$k} = $v;
3375             } else {
3376                 $options{$_} = 1;
3377             }
3378         }
3379         F->error and die $!;
3380         close F;
3381     } else {
3382         die $! unless $!==&ENOENT;
3383     }
3384
3385     if (!open F, "debian/source/format") {
3386         die $! unless $!==&ENOENT;
3387         return '';
3388     }
3389     $_ = <F>;
3390     F->error and die $!;
3391     chomp;
3392     return ($_, \%options);
3393 }
3394
3395 sub madformat_wantfixup ($) {
3396     my ($format) = @_;
3397     return 0 unless $format eq '3.0 (quilt)';
3398     our $quilt_mode_warned;
3399     if ($quilt_mode eq 'nocheck') {
3400         progress "Not doing any fixup of \`$format' due to".
3401             " ----no-quilt-fixup or --quilt=nocheck"
3402             unless $quilt_mode_warned++;
3403         return 0;
3404     }
3405     progress "Format \`$format', need to check/update patch stack"
3406         unless $quilt_mode_warned++;
3407     return 1;
3408 }
3409
3410 sub maybe_split_brain_save ($$$) {
3411     my ($headref, $dgitview, $msg) = @_;
3412     # => message fragment "$saved" describing disposition of $dgitview
3413     return "commit id $dgitview" unless defined $split_brain_save;
3414     my @cmd = (shell_cmd "cd ../../../..",
3415                @git, qw(update-ref -m),
3416                "dgit --dgit-view-save $msg HEAD=$headref",
3417                $split_brain_save, $dgitview);
3418     runcmd @cmd;
3419     return "and left in $split_brain_save";
3420 }
3421
3422 # An "infopair" is a tuple [ $thing, $what ]
3423 # (often $thing is a commit hash; $what is a description)
3424
3425 sub infopair_cond_equal ($$) {
3426     my ($x,$y) = @_;
3427     $x->[0] eq $y->[0] or fail <<END;
3428 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3429 END
3430 };
3431
3432 sub infopair_lrf_tag_lookup ($$) {
3433     my ($tagnames, $what) = @_;
3434     # $tagname may be an array ref
3435     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3436     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3437     foreach my $tagname (@tagnames) {
3438         my $lrefname = lrfetchrefs."/tags/$tagname";
3439         my $tagobj = $lrfetchrefs_f{$lrefname};
3440         next unless defined $tagobj;
3441         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3442         return [ git_rev_parse($tagobj), $what ];
3443     }
3444     fail @tagnames==1 ? <<END : <<END;
3445 Wanted tag $what (@tagnames) on dgit server, but not found
3446 END
3447 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3448 END
3449 }
3450
3451 sub infopair_cond_ff ($$) {
3452     my ($anc,$desc) = @_;
3453     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3454 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3455 END
3456 };
3457
3458 sub pseudomerge_version_check ($$) {
3459     my ($clogp, $archive_hash) = @_;
3460
3461     my $arch_clogp = commit_getclogp $archive_hash;
3462     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3463                      'version currently in archive' ];
3464     if (defined $overwrite_version) {
3465         if (length $overwrite_version) {
3466             infopair_cond_equal([ $overwrite_version,
3467                                   '--overwrite= version' ],
3468                                 $i_arch_v);
3469         } else {
3470             my $v = $i_arch_v->[0];
3471             progress "Checking package changelog for archive version $v ...";
3472             eval {
3473                 my @xa = ("-f$v", "-t$v");
3474                 my $vclogp = parsechangelog @xa;
3475                 my $cv = [ (getfield $vclogp, 'Version'),
3476                            "Version field from dpkg-parsechangelog @xa" ];
3477                 infopair_cond_equal($i_arch_v, $cv);
3478             };
3479             if ($@) {
3480                 $@ =~ s/^dgit: //gm;
3481                 fail "$@".
3482                     "Perhaps debian/changelog does not mention $v ?";
3483             }
3484         }
3485     }
3486     
3487     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3488     return $i_arch_v;
3489 }
3490
3491 sub pseudomerge_make_commit ($$$$ $$) {
3492     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3493         $msg_cmd, $msg_msg) = @_;
3494     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3495
3496     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3497     my $authline = clogp_authline $clogp;
3498
3499     chomp $msg_msg;
3500     $msg_cmd .=
3501         !defined $overwrite_version ? ""
3502         : !length  $overwrite_version ? " --overwrite"
3503         : " --overwrite=".$overwrite_version;
3504
3505     mkpath '.git/dgit';
3506     my $pmf = ".git/dgit/pseudomerge";
3507     open MC, ">", $pmf or die "$pmf $!";
3508     print MC <<END or die $!;
3509 tree $tree
3510 parent $dgitview
3511 parent $archive_hash
3512 author $authline
3513 commiter $authline
3514
3515 $msg_msg
3516
3517 [$msg_cmd]
3518 END
3519     close MC or die $!;
3520
3521     return make_commit($pmf);
3522 }
3523
3524 sub splitbrain_pseudomerge ($$$$) {
3525     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3526     # => $merged_dgitview
3527     printdebug "splitbrain_pseudomerge...\n";
3528     #
3529     #     We:      debian/PREVIOUS    HEAD($maintview)
3530     # expect:          o ----------------- o
3531     #                    \                   \
3532     #                     o                   o
3533     #                 a/d/PREVIOUS        $dgitview
3534     #                $archive_hash              \
3535     #  If so,                \                   \
3536     #  we do:                 `------------------ o
3537     #   this:                                   $dgitview'
3538     #
3539
3540     return $dgitview unless defined $archive_hash;
3541
3542     printdebug "splitbrain_pseudomerge...\n";
3543
3544     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3545
3546     if (!defined $overwrite_version) {
3547         progress "Checking that HEAD inciudes all changes in archive...";
3548     }
3549
3550     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3551
3552     if (defined $overwrite_version) {
3553     } elsif (!eval {
3554         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3555         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3556         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3557         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3558         my $i_archive = [ $archive_hash, "current archive contents" ];
3559
3560         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3561
3562         infopair_cond_equal($i_dgit, $i_archive);
3563         infopair_cond_ff($i_dep14, $i_dgit);
3564         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3565         1;
3566     }) {
3567         print STDERR <<END;
3568 $us: check failed (maybe --overwrite is needed, consult documentation)
3569 END
3570         die "$@";
3571     }
3572
3573     my $r = pseudomerge_make_commit
3574         $clogp, $dgitview, $archive_hash, $i_arch_v,
3575         "dgit --quilt=$quilt_mode",
3576         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3577 Declare fast forward from $i_arch_v->[0]
3578 END_OVERWR
3579 Make fast forward from $i_arch_v->[0]
3580 END_MAKEFF
3581
3582     maybe_split_brain_save $maintview, $r, "pseudomerge";
3583
3584     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3585     return $r;
3586 }       
3587
3588 sub plain_overwrite_pseudomerge ($$$) {
3589     my ($clogp, $head, $archive_hash) = @_;
3590
3591     printdebug "plain_overwrite_pseudomerge...";
3592
3593     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3594
3595     return $head if is_fast_fwd $archive_hash, $head;
3596
3597     my $m = "Declare fast forward from $i_arch_v->[0]";
3598
3599     my $r = pseudomerge_make_commit
3600         $clogp, $head, $archive_hash, $i_arch_v,
3601         "dgit", $m;
3602
3603     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3604
3605     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3606     return $r;
3607 }
3608
3609 sub push_parse_changelog ($) {
3610     my ($clogpfn) = @_;
3611
3612     my $clogp = Dpkg::Control::Hash->new();
3613     $clogp->load($clogpfn) or die;
3614
3615     my $clogpackage = getfield $clogp, 'Source';
3616     $package //= $clogpackage;
3617     fail "-p specified $package but changelog specified $clogpackage"
3618         unless $package eq $clogpackage;
3619     my $cversion = getfield $clogp, 'Version';
3620     my $tag = debiantag($cversion, access_nomdistro);
3621     runcmd @git, qw(check-ref-format), $tag;
3622
3623     my $dscfn = dscfn($cversion);
3624
3625     return ($clogp, $cversion, $dscfn);
3626 }
3627
3628 sub push_parse_dsc ($$$) {
3629     my ($dscfn,$dscfnwhat, $cversion) = @_;
3630     $dsc = parsecontrol($dscfn,$dscfnwhat);
3631     my $dversion = getfield $dsc, 'Version';
3632     my $dscpackage = getfield $dsc, 'Source';
3633     ($dscpackage eq $package && $dversion eq $cversion) or
3634         fail "$dscfn is for $dscpackage $dversion".
3635             " but debian/changelog is for $package $cversion";
3636 }
3637
3638 sub push_tagwants ($$$$) {
3639     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3640     my @tagwants;
3641     push @tagwants, {
3642         TagFn => \&debiantag,
3643         Objid => $dgithead,
3644         TfSuffix => '',
3645         View => 'dgit',
3646     };
3647     if (defined $maintviewhead) {
3648         push @tagwants, {
3649             TagFn => \&debiantag_maintview,
3650             Objid => $maintviewhead,
3651             TfSuffix => '-maintview',
3652             View => 'maint',
3653         };
3654     }
3655     foreach my $tw (@tagwants) {
3656         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3657         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3658     }
3659     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3660     return @tagwants;
3661 }
3662
3663 sub push_mktags ($$ $$ $) {
3664     my ($clogp,$dscfn,
3665         $changesfile,$changesfilewhat,
3666         $tagwants) = @_;
3667
3668     die unless $tagwants->[0]{View} eq 'dgit';
3669
3670     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3671     $dsc->save("$dscfn.tmp") or die $!;
3672
3673     my $changes = parsecontrol($changesfile,$changesfilewhat);
3674     foreach my $field (qw(Source Distribution Version)) {
3675         $changes->{$field} eq $clogp->{$field} or
3676             fail "changes field $field \`$changes->{$field}'".
3677                 " does not match changelog \`$clogp->{$field}'";
3678     }
3679
3680     my $cversion = getfield $clogp, 'Version';
3681     my $clogsuite = getfield $clogp, 'Distribution';
3682
3683     # We make the git tag by hand because (a) that makes it easier
3684     # to control the "tagger" (b) we can do remote signing
3685     my $authline = clogp_authline $clogp;
3686     my $delibs = join(" ", "",@deliberatelies);
3687     my $declaredistro = access_nomdistro();
3688
3689     my $mktag = sub {
3690         my ($tw) = @_;
3691         my $tfn = $tw->{Tfn};
3692         my $head = $tw->{Objid};
3693         my $tag = $tw->{Tag};
3694
3695         open TO, '>', $tfn->('.tmp') or die $!;
3696         print TO <<END or die $!;
3697 object $head
3698 type commit
3699 tag $tag
3700 tagger $authline
3701
3702 END
3703         if ($tw->{View} eq 'dgit') {
3704             print TO <<END or die $!;
3705 $package release $cversion for $clogsuite ($csuite) [dgit]
3706 [dgit distro=$declaredistro$delibs]
3707 END
3708             foreach my $ref (sort keys %previously) {
3709                 print TO <<END or die $!;
3710 [dgit previously:$ref=$previously{$ref}]
3711 END
3712             }
3713         } elsif ($tw->{View} eq 'maint') {
3714             print TO <<END or die $!;
3715 $package release $cversion for $clogsuite ($csuite)
3716 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3717 END
3718         } else {
3719             die Dumper($tw)."?";
3720         }
3721
3722         close TO or die $!;
3723
3724         my $tagobjfn = $tfn->('.tmp');
3725         if ($sign) {
3726             if (!defined $keyid) {
3727                 $keyid = access_cfg('keyid','RETURN-UNDEF');
3728             }
3729             if (!defined $keyid) {
3730                 $keyid = getfield $clogp, 'Maintainer';
3731             }
3732             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3733             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3734             push @sign_cmd, qw(-u),$keyid if defined $keyid;
3735             push @sign_cmd, $tfn->('.tmp');
3736             runcmd_ordryrun @sign_cmd;
3737             if (act_scary()) {
3738                 $tagobjfn = $tfn->('.signed.tmp');
3739                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3740                     $tfn->('.tmp'), $tfn->('.tmp.asc');
3741             }
3742         }
3743         return $tagobjfn;
3744     };
3745
3746     my @r = map { $mktag->($_); } @$tagwants;
3747     return @r;
3748 }
3749
3750 sub sign_changes ($) {
3751     my ($changesfile) = @_;
3752     if ($sign) {
3753         my @debsign_cmd = @debsign;
3754         push @debsign_cmd, "-k$keyid" if defined $keyid;
3755         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3756         push @debsign_cmd, $changesfile;
3757         runcmd_ordryrun @debsign_cmd;
3758     }
3759 }
3760
3761 sub dopush () {
3762     printdebug "actually entering push\n";
3763
3764     supplementary_message(<<'END');
3765 Push failed, while checking state of the archive.
3766 You can retry the push, after fixing the problem, if you like.
3767 END
3768     if (check_for_git()) {
3769         git_fetch_us();
3770     }
3771     my $archive_hash = fetch_from_archive();
3772     if (!$archive_hash) {
3773         $new_package or
3774             fail "package appears to be new in this suite;".
3775                 " if this is intentional, use --new";
3776     }
3777
3778     supplementary_message(<<'END');
3779 Push failed, while preparing your push.
3780 You can retry the push, after fixing the problem, if you like.
3781 END
3782
3783     need_tagformat 'new', "quilt mode $quilt_mode"
3784         if quiltmode_splitbrain;
3785
3786     prep_ud();
3787
3788     access_giturl(); # check that success is vaguely likely
3789     select_tagformat();
3790
3791     my $clogpfn = ".git/dgit/changelog.822.tmp";
3792     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3793
3794     responder_send_file('parsed-changelog', $clogpfn);
3795
3796     my ($clogp, $cversion, $dscfn) =
3797         push_parse_changelog("$clogpfn");
3798
3799     my $dscpath = "$buildproductsdir/$dscfn";
3800     stat_exists $dscpath or
3801         fail "looked for .dsc $dscfn, but $!;".
3802             " maybe you forgot to build";
3803
3804     responder_send_file('dsc', $dscpath);
3805
3806     push_parse_dsc($dscpath, $dscfn, $cversion);
3807
3808     my $format = getfield $dsc, 'Format';
3809     printdebug "format $format\n";
3810
3811     my $actualhead = git_rev_parse('HEAD');
3812     my $dgithead = $actualhead;
3813     my $maintviewhead = undef;
3814
3815     my $upstreamversion = upstreamversion $clogp->{Version};
3816
3817     if (madformat_wantfixup($format)) {
3818         # user might have not used dgit build, so maybe do this now:
3819         if (quiltmode_splitbrain()) {
3820             changedir $ud;
3821             quilt_make_fake_dsc($upstreamversion);
3822             my $cachekey;
3823             ($dgithead, $cachekey) =
3824                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3825             $dgithead or fail
3826  "--quilt=$quilt_mode but no cached dgit view:
3827  perhaps tree changed since dgit build[-source] ?";
3828             $split_brain = 1;
3829             $dgithead = splitbrain_pseudomerge($clogp,
3830                                                $actualhead, $dgithead,
3831                                                $archive_hash);
3832             $maintviewhead = $actualhead;
3833             changedir '../../../..';
3834             prep_ud(); # so _only_subdir() works, below
3835         } else {
3836             commit_quilty_patch();
3837         }
3838     }
3839
3840     if (defined $overwrite_version && !defined $maintviewhead) {
3841         $dgithead = plain_overwrite_pseudomerge($clogp,
3842                                                 $dgithead,
3843                                                 $archive_hash);
3844     }
3845
3846     check_not_dirty();
3847
3848     my $forceflag = '';
3849     if ($archive_hash) {
3850         if (is_fast_fwd($archive_hash, $dgithead)) {
3851             # ok
3852         } elsif (deliberately_not_fast_forward) {
3853             $forceflag = '+';
3854         } else {
3855             fail "dgit push: HEAD is not a descendant".
3856                 " of the archive's version.\n".
3857                 "To overwrite the archive's contents,".
3858                 " pass --overwrite[=VERSION].\n".
3859                 "To rewind history, if permitted by the archive,".
3860                 " use --deliberately-not-fast-forward.";
3861         }
3862     }
3863
3864     changedir $ud;
3865     progress "checking that $dscfn corresponds to HEAD";
3866     runcmd qw(dpkg-source -x --),
3867         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3868     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3869     check_for_vendor_patches() if madformat($dsc->{format});
3870     changedir '../../../..';
3871     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3872     debugcmd "+",@diffcmd;
3873     $!=0; $?=-1;
3874     my $r = system @diffcmd;
3875     if ($r) {
3876         if ($r==256) {
3877             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3878             fail <<END
3879 HEAD specifies a different tree to $dscfn:
3880 $diffs
3881 Perhaps you forgot to build.  Or perhaps there is a problem with your
3882  source tree (see dgit(7) for some hints).  To see a full diff, run
3883    git diff $tree HEAD
3884 END
3885         } else {
3886             failedcmd @diffcmd;
3887         }
3888     }
3889     if (!$changesfile) {
3890         my $pat = changespat $cversion;
3891         my @cs = glob "$buildproductsdir/$pat";
3892         fail "failed to find unique changes file".
3893             " (looked for $pat in $buildproductsdir);".
3894             " perhaps you need to use dgit -C"
3895             unless @cs==1;
3896         ($changesfile) = @cs;
3897     } else {
3898         $changesfile = "$buildproductsdir/$changesfile";
3899     }
3900
3901     # Check that changes and .dsc agree enough
3902     $changesfile =~ m{[^/]*$};
3903     my $changes = parsecontrol($changesfile,$&);
3904     files_compare_inputs($dsc, $changes)
3905         unless forceing [qw(dsc-changes-mismatch)];
3906
3907     # Perhaps adjust .dsc to contain right set of origs
3908     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3909                                   $changesfile)
3910         unless forceing [qw(changes-origs-exactly)];
3911
3912     # Checks complete, we're going to try and go ahead:
3913
3914     responder_send_file('changes',$changesfile);
3915     responder_send_command("param head $dgithead");
3916     responder_send_command("param csuite $csuite");
3917     responder_send_command("param tagformat $tagformat");
3918     if (defined $maintviewhead) {
3919         die unless ($protovsn//4) >= 4;
3920         responder_send_command("param maint-view $maintviewhead");
3921     }
3922
3923     if (deliberately_not_fast_forward) {
3924         git_for_each_ref(lrfetchrefs, sub {
3925             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3926             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3927             responder_send_command("previously $rrefname=$objid");
3928             $previously{$rrefname} = $objid;
3929         });
3930     }
3931
3932     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3933                                  ".git/dgit/tag");
3934     my @tagobjfns;
3935
3936     supplementary_message(<<'END');
3937 Push failed, while signing the tag.
3938 You can retry the push, after fixing the problem, if you like.
3939 END
3940     # If we manage to sign but fail to record it anywhere, it's fine.
3941     if ($we_are_responder) {
3942         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3943         responder_receive_files('signed-tag', @tagobjfns);
3944     } else {
3945         @tagobjfns = push_mktags($clogp,$dscpath,
3946                               $changesfile,$changesfile,
3947                               \@tagwants);
3948     }
3949     supplementary_message(<<'END');
3950 Push failed, *after* signing the tag.
3951 If you want to try again, you should use a new version number.
3952 END
3953
3954     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3955
3956     foreach my $tw (@tagwants) {
3957         my $tag = $tw->{Tag};
3958         my $tagobjfn = $tw->{TagObjFn};
3959         my $tag_obj_hash =
3960             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3961         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3962         runcmd_ordryrun_local
3963             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3964     }
3965
3966     supplementary_message(<<'END');
3967 Push failed, while updating the remote git repository - see messages above.
3968 If you want to try again, you should use a new version number.
3969 END
3970     if (!check_for_git()) {
3971         create_remote_git_repo();
3972     }
3973
3974     my @pushrefs = $forceflag.$dgithead.":".rrref();
3975     foreach my $tw (@tagwants) {
3976         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3977     }
3978
3979     runcmd_ordryrun @git,
3980         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3981     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3982
3983     supplementary_message(<<'END');
3984 Push failed, after updating the remote git repository.
3985 If you want to try again, you must use a new version number.
3986 END
3987     if ($we_are_responder) {
3988         my $dryrunsuffix = act_local() ? "" : ".tmp";
3989         responder_receive_files('signed-dsc-changes',
3990                                 "$dscpath$dryrunsuffix",
3991                                 "$changesfile$dryrunsuffix");
3992     } else {
3993         if (act_local()) {
3994             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3995         } else {
3996             progress "[new .dsc left in $dscpath.tmp]";
3997         }
3998         sign_changes $changesfile;
3999     }
4000
4001     supplementary_message(<<END);
4002 Push failed, while uploading package(s) to the archive server.
4003 You can retry the upload of exactly these same files with dput of:
4004   $changesfile
4005 If that .changes file is broken, you will need to use a new version
4006 number for your next attempt at the upload.
4007 END
4008     my $host = access_cfg('upload-host','RETURN-UNDEF');
4009     my @hostarg = defined($host) ? ($host,) : ();
4010     runcmd_ordryrun @dput, @hostarg, $changesfile;
4011     printdone "pushed and uploaded $cversion";
4012
4013     supplementary_message('');
4014     responder_send_command("complete");
4015 }
4016
4017 sub cmd_clone {
4018     parseopts();
4019     notpushing();
4020     my $dstdir;
4021     badusage "-p is not allowed with clone; specify as argument instead"
4022         if defined $package;
4023     if (@ARGV==1) {
4024         ($package) = @ARGV;
4025     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
4026         ($package,$isuite) = @ARGV;
4027     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
4028         ($package,$dstdir) = @ARGV;
4029     } elsif (@ARGV==3) {
4030         ($package,$isuite,$dstdir) = @ARGV;
4031     } else {
4032         badusage "incorrect arguments to dgit clone";
4033     }
4034     $dstdir ||= "$package";
4035
4036     if (stat_exists $dstdir) {
4037         fail "$dstdir already exists";
4038     }
4039
4040     my $cwd_remove;
4041     if ($rmonerror && !$dryrun_level) {
4042         $cwd_remove= getcwd();
4043         unshift @end, sub { 
4044             return unless defined $cwd_remove;
4045             if (!chdir "$cwd_remove") {
4046                 return if $!==&ENOENT;
4047                 die "chdir $cwd_remove: $!";
4048             }
4049             printdebug "clone rmonerror removing $dstdir\n";
4050             if (stat $dstdir) {
4051                 rmtree($dstdir) or die "remove $dstdir: $!\n";
4052             } elsif (grep { $! == $_ }
4053                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
4054             } else {
4055                 print STDERR "check whether to remove $dstdir: $!\n";
4056             }
4057         };
4058     }
4059
4060     clone($dstdir);
4061     $cwd_remove = undef;
4062 }
4063
4064 sub branchsuite () {
4065     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
4066     if ($branch =~ m#$lbranch_re#o) {
4067         return $1;
4068     } else {
4069         return undef;
4070     }
4071 }
4072
4073 sub fetchpullargs () {
4074     notpushing();
4075     if (!defined $package) {
4076         my $sourcep = parsecontrol('debian/control','debian/control');
4077         $package = getfield $sourcep, 'Source';
4078     }
4079     if (@ARGV==0) {
4080         $isuite = branchsuite();
4081         if (!$isuite) {
4082             my $clogp = parsechangelog();
4083             $isuite = getfield $clogp, 'Distribution';
4084         }
4085     } elsif (@ARGV==1) {
4086         ($isuite) = @ARGV;
4087     } else {
4088         badusage "incorrect arguments to dgit fetch or dgit pull";
4089     }
4090 }
4091
4092 sub cmd_fetch {
4093     parseopts();
4094     fetchpullargs();
4095     my $multi_fetched = fork_for_multisuite(sub { });
4096     exit 0 if $multi_fetched;
4097     fetch();
4098 }
4099
4100 sub cmd_pull {
4101     parseopts();
4102     fetchpullargs();
4103     if (quiltmode_splitbrain()) {
4104         my ($format, $fopts) = get_source_format();
4105         madformat($format) and fail <<END
4106 dgit pull not yet supported in split view mode (--quilt=$quilt_mode)
4107 END
4108     }
4109     pull();
4110 }
4111
4112 sub cmd_push {
4113     parseopts();
4114     pushing();
4115     badusage "-p is not allowed with dgit push" if defined $package;
4116     check_not_dirty();
4117     my $clogp = parsechangelog();
4118     $package = getfield $clogp, 'Source';
4119     my $specsuite;
4120     if (@ARGV==0) {
4121     } elsif (@ARGV==1) {
4122         ($specsuite) = (@ARGV);
4123     } else {
4124         badusage "incorrect arguments to dgit push";
4125     }
4126     $isuite = getfield $clogp, 'Distribution';
4127     if ($new_package) {
4128         local ($package) = $existing_package; # this is a hack
4129         canonicalise_suite();
4130     } else {
4131         canonicalise_suite();
4132     }
4133     if (defined $specsuite &&
4134         $specsuite ne $isuite &&
4135         $specsuite ne $csuite) {
4136             fail "dgit push: changelog specifies $isuite ($csuite)".
4137                 " but command line specifies $specsuite";
4138     }
4139     dopush();
4140 }
4141
4142 #---------- remote commands' implementation ----------
4143
4144 sub cmd_remote_push_build_host {
4145     my ($nrargs) = shift @ARGV;
4146     my (@rargs) = @ARGV[0..$nrargs-1];
4147     @ARGV = @ARGV[$nrargs..$#ARGV];
4148     die unless @rargs;
4149     my ($dir,$vsnwant) = @rargs;
4150     # vsnwant is a comma-separated list; we report which we have
4151     # chosen in our ready response (so other end can tell if they
4152     # offered several)
4153     $debugprefix = ' ';
4154     $we_are_responder = 1;
4155     $us .= " (build host)";
4156
4157     pushing();
4158
4159     open PI, "<&STDIN" or die $!;
4160     open STDIN, "/dev/null" or die $!;
4161     open PO, ">&STDOUT" or die $!;
4162     autoflush PO 1;
4163     open STDOUT, ">&STDERR" or die $!;
4164     autoflush STDOUT 1;
4165
4166     $vsnwant //= 1;
4167     ($protovsn) = grep {
4168         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
4169     } @rpushprotovsn_support;
4170
4171     fail "build host has dgit rpush protocol versions ".
4172         (join ",", @rpushprotovsn_support).
4173         " but invocation host has $vsnwant"
4174         unless defined $protovsn;
4175
4176     responder_send_command("dgit-remote-push-ready $protovsn");
4177     rpush_handle_protovsn_bothends();
4178     changedir $dir;
4179     &cmd_push;
4180 }
4181
4182 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
4183 # ... for compatibility with proto vsn.1 dgit (just so that user gets
4184 #     a good error message)
4185
4186 sub rpush_handle_protovsn_bothends () {
4187     if ($protovsn < 4) {
4188         need_tagformat 'old', "rpush negotiated protocol $protovsn";
4189     }
4190     select_tagformat();
4191 }
4192
4193 our $i_tmp;
4194
4195 sub i_cleanup {
4196     local ($@, $?);
4197     my $report = i_child_report();
4198     if (defined $report) {
4199         printdebug "($report)\n";
4200     } elsif ($i_child_pid) {
4201         printdebug "(killing build host child $i_child_pid)\n";
4202         kill 15, $i_child_pid;
4203     }
4204     if (defined $i_tmp && !defined $initiator_tempdir) {
4205         changedir "/";
4206         eval { rmtree $i_tmp; };
4207     }
4208 }
4209
4210 END { i_cleanup(); }
4211
4212 sub i_method {
4213     my ($base,$selector,@args) = @_;
4214     $selector =~ s/\-/_/g;
4215     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
4216 }
4217
4218 sub cmd_rpush {
4219     pushing();
4220     my $host = nextarg;
4221     my $dir;
4222     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
4223         $host = $1;
4224         $dir = $'; #';
4225     } else {
4226         $dir = nextarg;
4227     }
4228     $dir =~ s{^-}{./-};
4229     my @rargs = ($dir);
4230     push @rargs, join ",", @rpushprotovsn_support;
4231     my @rdgit;
4232     push @rdgit, @dgit;
4233     push @rdgit, @ropts;
4234     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
4235     push @rdgit, @ARGV;
4236     my @cmd = (@ssh, $host, shellquote @rdgit);
4237     debugcmd "+",@cmd;
4238
4239     if (defined $initiator_tempdir) {
4240         rmtree $initiator_tempdir;
4241         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
4242         $i_tmp = $initiator_tempdir;
4243     } else {
4244         $i_tmp = tempdir();
4245     }
4246     $i_child_pid = open2(\*RO, \*RI, @cmd);
4247     changedir $i_tmp;
4248     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
4249     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
4250     $supplementary_message = '' unless $protovsn >= 3;
4251
4252     fail "rpush negotiated protocol version $protovsn".
4253         " which does not support quilt mode $quilt_mode"
4254         if quiltmode_splitbrain;
4255
4256     rpush_handle_protovsn_bothends();
4257     for (;;) {
4258         my ($icmd,$iargs) = initiator_expect {
4259             m/^(\S+)(?: (.*))?$/;
4260             ($1,$2);
4261         };
4262         i_method "i_resp", $icmd, $iargs;
4263     }
4264 }
4265
4266 sub i_resp_progress ($) {
4267     my ($rhs) = @_;
4268     my $msg = protocol_read_bytes \*RO, $rhs;
4269     progress $msg;
4270 }
4271
4272 sub i_resp_supplementary_message ($) {
4273     my ($rhs) = @_;
4274     $supplementary_message = protocol_read_bytes \*RO, $rhs;
4275 }
4276
4277 sub i_resp_complete {
4278     my $pid = $i_child_pid;
4279     $i_child_pid = undef; # prevents killing some other process with same pid
4280     printdebug "waiting for build host child $pid...\n";
4281     my $got = waitpid $pid, 0;
4282     die $! unless $got == $pid;
4283     die "build host child failed $?" if $?;
4284
4285     i_cleanup();
4286     printdebug "all done\n";
4287     exit 0;
4288 }
4289
4290 sub i_resp_file ($) {
4291     my ($keyword) = @_;
4292     my $localname = i_method "i_localname", $keyword;
4293     my $localpath = "$i_tmp/$localname";
4294     stat_exists $localpath and
4295         badproto \*RO, "file $keyword ($localpath) twice";
4296     protocol_receive_file \*RO, $localpath;
4297     i_method "i_file", $keyword;
4298 }
4299
4300 our %i_param;
4301
4302 sub i_resp_param ($) {
4303     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
4304     $i_param{$1} = $2;
4305 }
4306
4307 sub i_resp_previously ($) {
4308     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
4309         or badproto \*RO, "bad previously spec";
4310     my $r = system qw(git check-ref-format), $1;
4311     die "bad previously ref spec ($r)" if $r;
4312     $previously{$1} = $2;
4313 }
4314
4315 our %i_wanted;
4316
4317 sub i_resp_want ($) {
4318     my ($keyword) = @_;
4319     die "$keyword ?" if $i_wanted{$keyword}++;
4320     my @localpaths = i_method "i_want", $keyword;
4321     printdebug "[[  $keyword @localpaths\n";
4322     foreach my $localpath (@localpaths) {
4323         protocol_send_file \*RI, $localpath;
4324     }
4325     print RI "files-end\n" or die $!;
4326 }
4327
4328 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
4329
4330 sub i_localname_parsed_changelog {
4331     return "remote-changelog.822";
4332 }
4333 sub i_file_parsed_changelog {
4334     ($i_clogp, $i_version, $i_dscfn) =
4335         push_parse_changelog "$i_tmp/remote-changelog.822";
4336     die if $i_dscfn =~ m#/|^\W#;
4337 }
4338
4339 sub i_localname_dsc {
4340     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4341     return $i_dscfn;
4342 }
4343 sub i_file_dsc { }
4344
4345 sub i_localname_changes {
4346     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
4347     $i_changesfn = $i_dscfn;
4348     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
4349     return $i_changesfn;
4350 }
4351 sub i_file_changes { }
4352
4353 sub i_want_signed_tag {
4354     printdebug Dumper(\%i_param, $i_dscfn);
4355     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
4356         && defined $i_param{'csuite'}
4357         or badproto \*RO, "premature desire for signed-tag";
4358     my $head = $i_param{'head'};
4359     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
4360
4361     my $maintview = $i_param{'maint-view'};
4362     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
4363
4364     select_tagformat();
4365     if ($protovsn >= 4) {
4366         my $p = $i_param{'tagformat'} // '<undef>';
4367         $p eq $tagformat
4368             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
4369     }
4370
4371     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
4372     $csuite = $&;
4373     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
4374
4375     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
4376
4377     return
4378         push_mktags $i_clogp, $i_dscfn,
4379             $i_changesfn, 'remote changes',
4380             \@tagwants;
4381 }
4382
4383 sub i_want_signed_dsc_changes {
4384     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
4385     sign_changes $i_changesfn;
4386     return ($i_dscfn, $i_changesfn);
4387 }
4388
4389 #---------- building etc. ----------
4390
4391 our $version;
4392 our $sourcechanges;
4393 our $dscfn;
4394
4395 #----- `3.0 (quilt)' handling -----
4396
4397 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
4398
4399 sub quiltify_dpkg_commit ($$$;$) {
4400     my ($patchname,$author,$msg, $xinfo) = @_;
4401     $xinfo //= '';
4402
4403     mkpath '.git/dgit';
4404     my $descfn = ".git/dgit/quilt-description.tmp";
4405     open O, '>', $descfn or die "$descfn: $!";
4406     $msg =~ s/\n+/\n\n/;
4407     print O <<END or die $!;
4408 From: $author
4409 ${xinfo}Subject: $msg
4410 ---
4411
4412 END
4413     close O or die $!;
4414
4415     {
4416         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
4417         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
4418         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
4419         runcmd @dpkgsource, qw(--commit .), $patchname;
4420     }
4421 }
4422
4423 sub quiltify_trees_differ ($$;$$$) {
4424     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
4425     # returns true iff the two tree objects differ other than in debian/
4426     # with $finegrained,
4427     # returns bitmask 01 - differ in upstream files except .gitignore
4428     #                 02 - differ in .gitignore
4429     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
4430     #  is set for each modified .gitignore filename $fn
4431     # if $unrepres is defined, array ref to which is appeneded
4432     #  a list of unrepresentable changes (removals of upstream files
4433     #  (as messages)
4434     local $/=undef;
4435     my @cmd = (@git, qw(diff-tree -z));
4436     push @cmd, qw(--name-only) unless $unrepres;
4437     push @cmd, qw(-r) if $finegrained || $unrepres;
4438     push @cmd, $x, $y;
4439     my $diffs= cmdoutput @cmd;