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