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