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