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