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