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