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