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