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