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