chiark / gitweb /
Push reorg: Move ff check out of cmd_push into dpush (nfc)
[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     printdebug "actually entering push\n";
2498
2499     supplementary_message(<<'END');
2500 Push failed, while checking state of the archive.
2501 You can retry the push, after fixing the problem, if you like.
2502 END
2503     if (check_for_git()) {
2504         git_fetch_us();
2505     }
2506     my $forceflag = '';
2507     if (fetch_from_archive()) {
2508         if (is_fast_fwd(lrref(), 'HEAD')) {
2509             # ok
2510         } elsif (deliberately_not_fast_forward) {
2511             $forceflag = '+';
2512         } else {
2513             fail "dgit push: HEAD is not a descendant".
2514                 " of the archive's version.\n".
2515                 "dgit: To overwrite its contents,".
2516                 " use git merge -s ours ".lrref().".\n".
2517                 "dgit: To rewind history, if permitted by the archive,".
2518                 " use --deliberately-not-fast-forward";
2519         }
2520     } else {
2521         $new_package or
2522             fail "package appears to be new in this suite;".
2523                 " if this is intentional, use --new";
2524     }
2525
2526     supplementary_message(<<'END');
2527 Push failed, while preparing your push.
2528 You can retry the push, after fixing the problem, if you like.
2529 END
2530
2531     need_tagformat 'new', "quilt mode $quilt_mode"
2532         if quiltmode_splitbrain;
2533
2534     prep_ud();
2535
2536     access_giturl(); # check that success is vaguely likely
2537     select_tagformat();
2538
2539     my $clogpfn = ".git/dgit/changelog.822.tmp";
2540     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2541
2542     responder_send_file('parsed-changelog', $clogpfn);
2543
2544     my ($clogp, $cversion, $dscfn) =
2545         push_parse_changelog("$clogpfn");
2546
2547     my $dscpath = "$buildproductsdir/$dscfn";
2548     stat_exists $dscpath or
2549         fail "looked for .dsc $dscfn, but $!;".
2550             " maybe you forgot to build";
2551
2552     responder_send_file('dsc', $dscpath);
2553
2554     push_parse_dsc($dscpath, $dscfn, $cversion);
2555
2556     my $format = getfield $dsc, 'Format';
2557     printdebug "format $format\n";
2558
2559     my $actualhead = git_rev_parse('HEAD');
2560     my $dgithead = $actualhead;
2561     my $maintviewhead = undef;
2562
2563     if (madformat($format)) {
2564         # user might have not used dgit build, so maybe do this now:
2565         if (quiltmode_splitbrain()) {
2566             my $upstreamversion = $clogp->{Version};
2567             $upstreamversion =~ s/-[^-]*$//;
2568             changedir $ud;
2569             quilt_make_fake_dsc($upstreamversion);
2570             my ($dgitview, $cachekey) =
2571                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2572             $dgitview or fail
2573  "--quilt=$quilt_mode but no cached dgit view:
2574  perhaps tree changed since dgit build[-source] ?";
2575             $split_brain = 1;
2576             $dgithead = $dgitview;
2577             $maintviewhead = $actualhead;
2578             changedir '../../../..';
2579             prep_ud(); # so _only_subdir() works, below
2580         } else {
2581             commit_quilty_patch();
2582         }
2583     }
2584
2585     check_not_dirty();
2586     changedir $ud;
2587     progress "checking that $dscfn corresponds to HEAD";
2588     runcmd qw(dpkg-source -x --),
2589         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2590     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2591     check_for_vendor_patches() if madformat($dsc->{format});
2592     changedir '../../../..';
2593     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2594     my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2595     debugcmd "+",@diffcmd;
2596     $!=0; $?=-1;
2597     my $r = system @diffcmd;
2598     if ($r) {
2599         if ($r==256) {
2600             fail "$dscfn specifies a different tree to your HEAD commit;".
2601                 " perhaps you forgot to build".
2602                 ($diffopt eq '--exit-code' ? "" :
2603                  " (run with -D to see full diff output)");
2604         } else {
2605             failedcmd @diffcmd;
2606         }
2607     }
2608     if (!$changesfile) {
2609         my $pat = changespat $cversion;
2610         my @cs = glob "$buildproductsdir/$pat";
2611         fail "failed to find unique changes file".
2612             " (looked for $pat in $buildproductsdir);".
2613             " perhaps you need to use dgit -C"
2614             unless @cs==1;
2615         ($changesfile) = @cs;
2616     } else {
2617         $changesfile = "$buildproductsdir/$changesfile";
2618     }
2619
2620     responder_send_file('changes',$changesfile);
2621     responder_send_command("param head $dgithead");
2622     responder_send_command("param csuite $csuite");
2623     responder_send_command("param tagformat $tagformat");
2624     if (quiltmode_splitbrain) {
2625         die unless ($protovsn//4) >= 4;
2626         responder_send_command("param maint-view $maintviewhead");
2627     }
2628
2629     if (deliberately_not_fast_forward) {
2630         git_for_each_ref(lrfetchrefs, sub {
2631             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2632             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2633             responder_send_command("previously $rrefname=$objid");
2634             $previously{$rrefname} = $objid;
2635         });
2636     }
2637
2638     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2639                                  ".git/dgit/tag");
2640     my @tagobjfns;
2641
2642     supplementary_message(<<'END');
2643 Push failed, while signing the tag.
2644 You can retry the push, after fixing the problem, if you like.
2645 END
2646     # If we manage to sign but fail to record it anywhere, it's fine.
2647     if ($we_are_responder) {
2648         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2649         responder_receive_files('signed-tag', @tagobjfns);
2650     } else {
2651         @tagobjfns = push_mktags($clogp,$dscpath,
2652                               $changesfile,$changesfile,
2653                               \@tagwants);
2654     }
2655     supplementary_message(<<'END');
2656 Push failed, *after* signing the tag.
2657 If you want to try again, you should use a new version number.
2658 END
2659
2660     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2661
2662     foreach my $tw (@tagwants) {
2663         my $tag = $tw->{Tag};
2664         my $tagobjfn = $tw->{TagObjFn};
2665         my $tag_obj_hash =
2666             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2667         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2668         runcmd_ordryrun_local
2669             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2670     }
2671
2672     supplementary_message(<<'END');
2673 Push failed, while updating the remote git repository - see messages above.
2674 If you want to try again, you should use a new version number.
2675 END
2676     if (!check_for_git()) {
2677         create_remote_git_repo();
2678     }
2679
2680     my @pushrefs = $forceflag.$dgithead.":".rrref();
2681     foreach my $tw (@tagwants) {
2682         my $view = $tw->{View};
2683         next unless $view eq 'dgit'
2684             or any { $_ eq $view } access_cfg_tagformats();
2685             # ^ $view is "dgit" or "maint" so this looks for "maint"
2686             # in archive supported tagformats.
2687         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2688     }
2689
2690     runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2691     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2692
2693     supplementary_message(<<'END');
2694 Push failed, after updating the remote git repository.
2695 If you want to try again, you must use a new version number.
2696 END
2697     if ($we_are_responder) {
2698         my $dryrunsuffix = act_local() ? "" : ".tmp";
2699         responder_receive_files('signed-dsc-changes',
2700                                 "$dscpath$dryrunsuffix",
2701                                 "$changesfile$dryrunsuffix");
2702     } else {
2703         if (act_local()) {
2704             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2705         } else {
2706             progress "[new .dsc left in $dscpath.tmp]";
2707         }
2708         sign_changes $changesfile;
2709     }
2710
2711     supplementary_message(<<END);
2712 Push failed, while uploading package(s) to the archive server.
2713 You can retry the upload of exactly these same files with dput of:
2714   $changesfile
2715 If that .changes file is broken, you will need to use a new version
2716 number for your next attempt at the upload.
2717 END
2718     my $host = access_cfg('upload-host','RETURN-UNDEF');
2719     my @hostarg = defined($host) ? ($host,) : ();
2720     runcmd_ordryrun @dput, @hostarg, $changesfile;
2721     printdone "pushed and uploaded $cversion";
2722
2723     supplementary_message('');
2724     responder_send_command("complete");
2725 }
2726
2727 sub cmd_clone {
2728     parseopts();
2729     notpushing();
2730     my $dstdir;
2731     badusage "-p is not allowed with clone; specify as argument instead"
2732         if defined $package;
2733     if (@ARGV==1) {
2734         ($package) = @ARGV;
2735     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2736         ($package,$isuite) = @ARGV;
2737     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2738         ($package,$dstdir) = @ARGV;
2739     } elsif (@ARGV==3) {
2740         ($package,$isuite,$dstdir) = @ARGV;
2741     } else {
2742         badusage "incorrect arguments to dgit clone";
2743     }
2744     $dstdir ||= "$package";
2745
2746     if (stat_exists $dstdir) {
2747         fail "$dstdir already exists";
2748     }
2749
2750     my $cwd_remove;
2751     if ($rmonerror && !$dryrun_level) {
2752         $cwd_remove= getcwd();
2753         unshift @end, sub { 
2754             return unless defined $cwd_remove;
2755             if (!chdir "$cwd_remove") {
2756                 return if $!==&ENOENT;
2757                 die "chdir $cwd_remove: $!";
2758             }
2759             if (stat $dstdir) {
2760                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2761             } elsif (!grep { $! == $_ }
2762                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2763             } else {
2764                 print STDERR "check whether to remove $dstdir: $!\n";
2765             }
2766         };
2767     }
2768
2769     clone($dstdir);
2770     $cwd_remove = undef;
2771 }
2772
2773 sub branchsuite () {
2774     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2775     if ($branch =~ m#$lbranch_re#o) {
2776         return $1;
2777     } else {
2778         return undef;
2779     }
2780 }
2781
2782 sub fetchpullargs () {
2783     notpushing();
2784     if (!defined $package) {
2785         my $sourcep = parsecontrol('debian/control','debian/control');
2786         $package = getfield $sourcep, 'Source';
2787     }
2788     if (@ARGV==0) {
2789 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2790         if (!$isuite) {
2791             my $clogp = parsechangelog();
2792             $isuite = getfield $clogp, 'Distribution';
2793         }
2794         canonicalise_suite();
2795         progress "fetching from suite $csuite";
2796     } elsif (@ARGV==1) {
2797         ($isuite) = @ARGV;
2798         canonicalise_suite();
2799     } else {
2800         badusage "incorrect arguments to dgit fetch or dgit pull";
2801     }
2802 }
2803
2804 sub cmd_fetch {
2805     parseopts();
2806     fetchpullargs();
2807     fetch();
2808 }
2809
2810 sub cmd_pull {
2811     parseopts();
2812     fetchpullargs();
2813     pull();
2814 }
2815
2816 sub cmd_push {
2817     parseopts();
2818     pushing();
2819     badusage "-p is not allowed with dgit push" if defined $package;
2820     check_not_dirty();
2821     my $clogp = parsechangelog();
2822     $package = getfield $clogp, 'Source';
2823     my $specsuite;
2824     if (@ARGV==0) {
2825     } elsif (@ARGV==1) {
2826         ($specsuite) = (@ARGV);
2827     } else {
2828         badusage "incorrect arguments to dgit push";
2829     }
2830     $isuite = getfield $clogp, 'Distribution';
2831     if ($new_package) {
2832         local ($package) = $existing_package; # this is a hack
2833         canonicalise_suite();
2834     } else {
2835         canonicalise_suite();
2836     }
2837     if (defined $specsuite &&
2838         $specsuite ne $isuite &&
2839         $specsuite ne $csuite) {
2840             fail "dgit push: changelog specifies $isuite ($csuite)".
2841                 " but command line specifies $specsuite";
2842     }
2843     dopush();
2844 }
2845
2846 #---------- remote commands' implementation ----------
2847
2848 sub cmd_remote_push_build_host {
2849     my ($nrargs) = shift @ARGV;
2850     my (@rargs) = @ARGV[0..$nrargs-1];
2851     @ARGV = @ARGV[$nrargs..$#ARGV];
2852     die unless @rargs;
2853     my ($dir,$vsnwant) = @rargs;
2854     # vsnwant is a comma-separated list; we report which we have
2855     # chosen in our ready response (so other end can tell if they
2856     # offered several)
2857     $debugprefix = ' ';
2858     $we_are_responder = 1;
2859     $us .= " (build host)";
2860
2861     pushing();
2862
2863     open PI, "<&STDIN" or die $!;
2864     open STDIN, "/dev/null" or die $!;
2865     open PO, ">&STDOUT" or die $!;
2866     autoflush PO 1;
2867     open STDOUT, ">&STDERR" or die $!;
2868     autoflush STDOUT 1;
2869
2870     $vsnwant //= 1;
2871     ($protovsn) = grep {
2872         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2873     } @rpushprotovsn_support;
2874
2875     fail "build host has dgit rpush protocol versions ".
2876         (join ",", @rpushprotovsn_support).
2877         " but invocation host has $vsnwant"
2878         unless defined $protovsn;
2879
2880     responder_send_command("dgit-remote-push-ready $protovsn");
2881     rpush_handle_protovsn_bothends();
2882     changedir $dir;
2883     &cmd_push;
2884 }
2885
2886 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2887 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2888 #     a good error message)
2889
2890 sub rpush_handle_protovsn_bothends () {
2891     if ($protovsn < 4) {
2892         need_tagformat 'old', "rpush negotiated protocol $protovsn";
2893     }
2894     select_tagformat();
2895 }
2896
2897 our $i_tmp;
2898
2899 sub i_cleanup {
2900     local ($@, $?);
2901     my $report = i_child_report();
2902     if (defined $report) {
2903         printdebug "($report)\n";
2904     } elsif ($i_child_pid) {
2905         printdebug "(killing build host child $i_child_pid)\n";
2906         kill 15, $i_child_pid;
2907     }
2908     if (defined $i_tmp && !defined $initiator_tempdir) {
2909         changedir "/";
2910         eval { rmtree $i_tmp; };
2911     }
2912 }
2913
2914 END { i_cleanup(); }
2915
2916 sub i_method {
2917     my ($base,$selector,@args) = @_;
2918     $selector =~ s/\-/_/g;
2919     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2920 }
2921
2922 sub cmd_rpush {
2923     pushing();
2924     my $host = nextarg;
2925     my $dir;
2926     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2927         $host = $1;
2928         $dir = $'; #';
2929     } else {
2930         $dir = nextarg;
2931     }
2932     $dir =~ s{^-}{./-};
2933     my @rargs = ($dir);
2934     push @rargs, join ",", @rpushprotovsn_support;
2935     my @rdgit;
2936     push @rdgit, @dgit;
2937     push @rdgit, @ropts;
2938     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2939     push @rdgit, @ARGV;
2940     my @cmd = (@ssh, $host, shellquote @rdgit);
2941     debugcmd "+",@cmd;
2942
2943     if (defined $initiator_tempdir) {
2944         rmtree $initiator_tempdir;
2945         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2946         $i_tmp = $initiator_tempdir;
2947     } else {
2948         $i_tmp = tempdir();
2949     }
2950     $i_child_pid = open2(\*RO, \*RI, @cmd);
2951     changedir $i_tmp;
2952     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2953     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2954     $supplementary_message = '' unless $protovsn >= 3;
2955
2956     fail "rpush negotiated protocol version $protovsn".
2957         " which does not support quilt mode $quilt_mode"
2958         if quiltmode_splitbrain;
2959
2960     rpush_handle_protovsn_bothends();
2961     for (;;) {
2962         my ($icmd,$iargs) = initiator_expect {
2963             m/^(\S+)(?: (.*))?$/;
2964             ($1,$2);
2965         };
2966         i_method "i_resp", $icmd, $iargs;
2967     }
2968 }
2969
2970 sub i_resp_progress ($) {
2971     my ($rhs) = @_;
2972     my $msg = protocol_read_bytes \*RO, $rhs;
2973     progress $msg;
2974 }
2975
2976 sub i_resp_supplementary_message ($) {
2977     my ($rhs) = @_;
2978     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2979 }
2980
2981 sub i_resp_complete {
2982     my $pid = $i_child_pid;
2983     $i_child_pid = undef; # prevents killing some other process with same pid
2984     printdebug "waiting for build host child $pid...\n";
2985     my $got = waitpid $pid, 0;
2986     die $! unless $got == $pid;
2987     die "build host child failed $?" if $?;
2988
2989     i_cleanup();
2990     printdebug "all done\n";
2991     exit 0;
2992 }
2993
2994 sub i_resp_file ($) {
2995     my ($keyword) = @_;
2996     my $localname = i_method "i_localname", $keyword;
2997     my $localpath = "$i_tmp/$localname";
2998     stat_exists $localpath and
2999         badproto \*RO, "file $keyword ($localpath) twice";
3000     protocol_receive_file \*RO, $localpath;
3001     i_method "i_file", $keyword;
3002 }
3003
3004 our %i_param;
3005
3006 sub i_resp_param ($) {
3007     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3008     $i_param{$1} = $2;
3009 }
3010
3011 sub i_resp_previously ($) {
3012     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3013         or badproto \*RO, "bad previously spec";
3014     my $r = system qw(git check-ref-format), $1;
3015     die "bad previously ref spec ($r)" if $r;
3016     $previously{$1} = $2;
3017 }
3018
3019 our %i_wanted;
3020
3021 sub i_resp_want ($) {
3022     my ($keyword) = @_;
3023     die "$keyword ?" if $i_wanted{$keyword}++;
3024     my @localpaths = i_method "i_want", $keyword;
3025     printdebug "[[  $keyword @localpaths\n";
3026     foreach my $localpath (@localpaths) {
3027         protocol_send_file \*RI, $localpath;
3028     }
3029     print RI "files-end\n" or die $!;
3030 }
3031
3032 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3033
3034 sub i_localname_parsed_changelog {
3035     return "remote-changelog.822";
3036 }
3037 sub i_file_parsed_changelog {
3038     ($i_clogp, $i_version, $i_dscfn) =
3039         push_parse_changelog "$i_tmp/remote-changelog.822";
3040     die if $i_dscfn =~ m#/|^\W#;
3041 }
3042
3043 sub i_localname_dsc {
3044     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3045     return $i_dscfn;
3046 }
3047 sub i_file_dsc { }
3048
3049 sub i_localname_changes {
3050     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3051     $i_changesfn = $i_dscfn;
3052     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3053     return $i_changesfn;
3054 }
3055 sub i_file_changes { }
3056
3057 sub i_want_signed_tag {
3058     printdebug Dumper(\%i_param, $i_dscfn);
3059     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3060         && defined $i_param{'csuite'}
3061         or badproto \*RO, "premature desire for signed-tag";
3062     my $head = $i_param{'head'};
3063     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3064
3065     my $maintview = $i_param{'maint-view'};
3066     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3067
3068     select_tagformat();
3069     if ($protovsn >= 4) {
3070         my $p = $i_param{'tagformat'} // '<undef>';
3071         $p eq $tagformat
3072             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3073     }
3074
3075     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3076     $csuite = $&;
3077     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3078
3079     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3080
3081     return
3082         push_mktags $i_clogp, $i_dscfn,
3083             $i_changesfn, 'remote changes',
3084             \@tagwants;
3085 }
3086
3087 sub i_want_signed_dsc_changes {
3088     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3089     sign_changes $i_changesfn;
3090     return ($i_dscfn, $i_changesfn);
3091 }
3092
3093 #---------- building etc. ----------
3094
3095 our $version;
3096 our $sourcechanges;
3097 our $dscfn;
3098
3099 #----- `3.0 (quilt)' handling -----
3100
3101 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3102
3103 sub quiltify_dpkg_commit ($$$;$) {
3104     my ($patchname,$author,$msg, $xinfo) = @_;
3105     $xinfo //= '';
3106
3107     mkpath '.git/dgit';
3108     my $descfn = ".git/dgit/quilt-description.tmp";
3109     open O, '>', $descfn or die "$descfn: $!";
3110     $msg =~ s/\s+$//g;
3111     $msg =~ s/\n/\n /g;
3112     $msg =~ s/^\s+$/ ./mg;
3113     print O <<END or die $!;
3114 Description: $msg
3115 Author: $author
3116 $xinfo
3117 ---
3118
3119 END
3120     close O or die $!;
3121
3122     {
3123         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3124         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3125         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3126         runcmd @dpkgsource, qw(--commit .), $patchname;
3127     }
3128 }
3129
3130 sub quiltify_trees_differ ($$;$$) {
3131     my ($x,$y,$finegrained,$ignorenamesr) = @_;
3132     # returns true iff the two tree objects differ other than in debian/
3133     # with $finegrained,
3134     # returns bitmask 01 - differ in upstream files except .gitignore
3135     #                 02 - differ in .gitignore
3136     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3137     #  is set for each modified .gitignore filename $fn
3138     local $/=undef;
3139     my @cmd = (@git, qw(diff-tree --name-only -z));
3140     push @cmd, qw(-r) if $finegrained;
3141     push @cmd, $x, $y;
3142     my $diffs= cmdoutput @cmd;
3143     my $r = 0;
3144     foreach my $f (split /\0/, $diffs) {
3145         next if $f =~ m#^debian(?:/.*)?$#s;
3146         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3147         $r |= $isignore ? 02 : 01;
3148         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3149     }
3150     printdebug "quiltify_trees_differ $x $y => $r\n";
3151     return $r;
3152 }
3153
3154 sub quiltify_tree_sentinelfiles ($) {
3155     # lists the `sentinel' files present in the tree
3156     my ($x) = @_;
3157     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3158         qw(-- debian/rules debian/control);
3159     $r =~ s/\n/,/g;
3160     return $r;
3161 }
3162
3163 sub quiltify_splitbrain_needed () {
3164     if (!$split_brain) {
3165         progress "dgit view: changes are required...";
3166         runcmd @git, qw(checkout -q -b dgit-view);
3167         $split_brain = 1;
3168     }
3169 }
3170
3171 sub quiltify_splitbrain ($$$$$$) {
3172     my ($clogp, $unapplied, $headref, $diffbits,
3173         $editedignores, $cachekey) = @_;
3174     if ($quilt_mode !~ m/gbp|dpm/) {
3175         # treat .gitignore just like any other upstream file
3176         $diffbits = { %$diffbits };
3177         $_ = !!$_ foreach values %$diffbits;
3178     }
3179     # We would like any commits we generate to be reproducible
3180     my @authline = clogp_authline($clogp);
3181     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
3182     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3183     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
3184         
3185     if ($quilt_mode =~ m/gbp|unapplied/ &&
3186         ($diffbits->{H2O} & 01)) {
3187         my $msg =
3188  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3189  " but git tree differs from orig in upstream files.";
3190         if (!stat_exists "debian/patches") {
3191             $msg .=
3192  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3193         }  
3194         fail $msg;
3195     }
3196     if ($quilt_mode =~ m/gbp|unapplied/ &&
3197         ($diffbits->{O2A} & 01)) { # some patches
3198         quiltify_splitbrain_needed();
3199         progress "dgit view: creating patches-applied version using gbp pq";
3200         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3201         # gbp pq import creates a fresh branch; push back to dgit-view
3202         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3203         runcmd @git, qw(checkout -q dgit-view);
3204     }
3205     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3206         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3207         quiltify_splitbrain_needed();
3208         progress "dgit view: creating patch to represent .gitignore changes";
3209         ensuredir "debian/patches";
3210         my $gipatch = "debian/patches/auto-gitignore";
3211         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3212         stat GIPATCH or die "$gipatch: $!";
3213         fail "$gipatch already exists; but want to create it".
3214             " to record .gitignore changes" if (stat _)[7];
3215         print GIPATCH <<END or die "$gipatch: $!";
3216 Subject: Update .gitignore from Debian packaging branch
3217
3218 The Debian packaging git branch contains these updates to the upstream
3219 .gitignore file(s).  This patch is autogenerated, to provide these
3220 updates to users of the official Debian archive view of the package.
3221
3222 [dgit version $our_version]
3223 ---
3224 END
3225         close GIPATCH or die "$gipatch: $!";
3226         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3227             $unapplied, $headref, "--", sort keys %$editedignores;
3228         open SERIES, "+>>", "debian/patches/series" or die $!;
3229         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3230         my $newline;
3231         defined read SERIES, $newline, 1 or die $!;
3232         print SERIES "\n" or die $! unless $newline eq "\n";
3233         print SERIES "auto-gitignore\n" or die $!;
3234         close SERIES or die  $!;
3235         runcmd @git, qw(add -- debian/patches/series), $gipatch;
3236         commit_admin "Commit patch to update .gitignore";
3237     }
3238
3239     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3240
3241     changedir '../../../..';
3242     ensuredir ".git/logs/refs/dgit-intern";
3243     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3244       or die $!;
3245     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3246         $dgitview;
3247
3248     progress "dgit view: created (commit id $dgitview)";
3249
3250     changedir '.git/dgit/unpack/work';
3251 }
3252
3253 sub quiltify ($$$$) {
3254     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3255
3256     # Quilt patchification algorithm
3257     #
3258     # We search backwards through the history of the main tree's HEAD
3259     # (T) looking for a start commit S whose tree object is identical
3260     # to to the patch tip tree (ie the tree corresponding to the
3261     # current dpkg-committed patch series).  For these purposes
3262     # `identical' disregards anything in debian/ - this wrinkle is
3263     # necessary because dpkg-source treates debian/ specially.
3264     #
3265     # We can only traverse edges where at most one of the ancestors'
3266     # trees differs (in changes outside in debian/).  And we cannot
3267     # handle edges which change .pc/ or debian/patches.  To avoid
3268     # going down a rathole we avoid traversing edges which introduce
3269     # debian/rules or debian/control.  And we set a limit on the
3270     # number of edges we are willing to look at.
3271     #
3272     # If we succeed, we walk forwards again.  For each traversed edge
3273     # PC (with P parent, C child) (starting with P=S and ending with
3274     # C=T) to we do this:
3275     #  - git checkout C
3276     #  - dpkg-source --commit with a patch name and message derived from C
3277     # After traversing PT, we git commit the changes which
3278     # should be contained within debian/patches.
3279
3280     # The search for the path S..T is breadth-first.  We maintain a
3281     # todo list containing search nodes.  A search node identifies a
3282     # commit, and looks something like this:
3283     #  $p = {
3284     #      Commit => $git_commit_id,
3285     #      Child => $c,                          # or undef if P=T
3286     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
3287     #      Nontrivial => true iff $p..$c has relevant changes
3288     #  };
3289
3290     my @todo;
3291     my @nots;
3292     my $sref_S;
3293     my $max_work=100;
3294     my %considered; # saves being exponential on some weird graphs
3295
3296     my $t_sentinels = quiltify_tree_sentinelfiles $target;
3297
3298     my $not = sub {
3299         my ($search,$whynot) = @_;
3300         printdebug " search NOT $search->{Commit} $whynot\n";
3301         $search->{Whynot} = $whynot;
3302         push @nots, $search;
3303         no warnings qw(exiting);
3304         next;
3305     };
3306
3307     push @todo, {
3308         Commit => $target,
3309     };
3310
3311     while (@todo) {
3312         my $c = shift @todo;
3313         next if $considered{$c->{Commit}}++;
3314
3315         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3316
3317         printdebug "quiltify investigate $c->{Commit}\n";
3318
3319         # are we done?
3320         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3321             printdebug " search finished hooray!\n";
3322             $sref_S = $c;
3323             last;
3324         }
3325
3326         if ($quilt_mode eq 'nofix') {
3327             fail "quilt fixup required but quilt mode is \`nofix'\n".
3328                 "HEAD commit $c->{Commit} differs from tree implied by ".
3329                 " debian/patches (tree object $oldtiptree)";
3330         }
3331         if ($quilt_mode eq 'smash') {
3332             printdebug " search quitting smash\n";
3333             last;
3334         }
3335
3336         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3337         $not->($c, "has $c_sentinels not $t_sentinels")
3338             if $c_sentinels ne $t_sentinels;
3339
3340         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3341         $commitdata =~ m/\n\n/;
3342         $commitdata =~ $`;
3343         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3344         @parents = map { { Commit => $_, Child => $c } } @parents;
3345
3346         $not->($c, "root commit") if !@parents;
3347
3348         foreach my $p (@parents) {
3349             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3350         }
3351         my $ndiffers = grep { $_->{Nontrivial} } @parents;
3352         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3353
3354         foreach my $p (@parents) {
3355             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3356
3357             my @cmd= (@git, qw(diff-tree -r --name-only),
3358                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3359             my $patchstackchange = cmdoutput @cmd;
3360             if (length $patchstackchange) {
3361                 $patchstackchange =~ s/\n/,/g;
3362                 $not->($p, "changed $patchstackchange");
3363             }
3364
3365             printdebug " search queue P=$p->{Commit} ",
3366                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3367             push @todo, $p;
3368         }
3369     }
3370
3371     if (!$sref_S) {
3372         printdebug "quiltify want to smash\n";
3373
3374         my $abbrev = sub {
3375             my $x = $_[0]{Commit};
3376             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3377             return $x;
3378         };
3379         my $reportnot = sub {
3380             my ($notp) = @_;
3381             my $s = $abbrev->($notp);
3382             my $c = $notp->{Child};
3383             $s .= "..".$abbrev->($c) if $c;
3384             $s .= ": ".$notp->{Whynot};
3385             return $s;
3386         };
3387         if ($quilt_mode eq 'linear') {
3388             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
3389             foreach my $notp (@nots) {
3390                 print STDERR "$us:  ", $reportnot->($notp), "\n";
3391             }
3392             print STDERR "$us: $_\n" foreach @$failsuggestion;
3393             fail "quilt fixup naive history linearisation failed.\n".
3394  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3395         } elsif ($quilt_mode eq 'smash') {
3396         } elsif ($quilt_mode eq 'auto') {
3397             progress "quilt fixup cannot be linear, smashing...";
3398         } else {
3399             die "$quilt_mode ?";
3400         }
3401
3402         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3403         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3404         my $ncommits = 3;
3405         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3406
3407         quiltify_dpkg_commit "auto-$version-$target-$time",
3408             (getfield $clogp, 'Maintainer'),
3409             "Automatically generated patch ($clogp->{Version})\n".
3410             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3411         return;
3412     }
3413
3414     progress "quiltify linearisation planning successful, executing...";
3415
3416     for (my $p = $sref_S;
3417          my $c = $p->{Child};
3418          $p = $p->{Child}) {
3419         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3420         next unless $p->{Nontrivial};
3421
3422         my $cc = $c->{Commit};
3423
3424         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3425         $commitdata =~ m/\n\n/ or die "$c ?";
3426         $commitdata = $`;
3427         my $msg = $'; #';
3428         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3429         my $author = $1;
3430
3431         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3432
3433         my $title = $1;
3434         my $patchname = $title;
3435         $patchname =~ s/[.:]$//;
3436         $patchname =~ y/ A-Z/-a-z/;
3437         $patchname =~ y/-a-z0-9_.+=~//cd;
3438         $patchname =~ s/^\W/x-$&/;
3439         $patchname = substr($patchname,0,40);
3440         my $index;
3441         for ($index='';
3442              stat "debian/patches/$patchname$index";
3443              $index++) { }
3444         $!==ENOENT or die "$patchname$index $!";
3445
3446         runcmd @git, qw(checkout -q), $cc;
3447
3448         # We use the tip's changelog so that dpkg-source doesn't
3449         # produce complaining messages from dpkg-parsechangelog.  None
3450         # of the information dpkg-source gets from the changelog is
3451         # actually relevant - it gets put into the original message
3452         # which dpkg-source provides our stunt editor, and then
3453         # overwritten.
3454         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3455
3456         quiltify_dpkg_commit "$patchname$index", $author, $msg,
3457             "X-Dgit-Generated: $clogp->{Version} $cc\n";
3458
3459         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3460     }
3461
3462     runcmd @git, qw(checkout -q master);
3463 }
3464
3465 sub build_maybe_quilt_fixup () {
3466     my ($format,$fopts) = get_source_format;
3467     return unless madformat $format;
3468     # sigh
3469
3470     check_for_vendor_patches();
3471
3472     my $clogp = parsechangelog();
3473     my $headref = git_rev_parse('HEAD');
3474
3475     prep_ud();
3476     changedir $ud;
3477
3478     my $upstreamversion=$version;
3479     $upstreamversion =~ s/-[^-]*$//;
3480
3481     if ($fopts->{'single-debian-patch'}) {
3482         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3483     } else {
3484         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3485     }
3486
3487     die 'bug' if $split_brain && !$need_split_build_invocation;
3488
3489     changedir '../../../..';
3490     runcmd_ordryrun_local
3491         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3492 }
3493
3494 sub quilt_fixup_mkwork ($) {
3495     my ($headref) = @_;
3496
3497     mkdir "work" or die $!;
3498     changedir "work";
3499     mktree_in_ud_here();
3500     runcmd @git, qw(reset -q --hard), $headref;
3501 }
3502
3503 sub quilt_fixup_linkorigs ($$) {
3504     my ($upstreamversion, $fn) = @_;
3505     # calls $fn->($leafname);
3506
3507     foreach my $f (<../../../../*>) { #/){
3508         my $b=$f; $b =~ s{.*/}{};
3509         {
3510             local ($debuglevel) = $debuglevel-1;
3511             printdebug "QF linkorigs $b, $f ?\n";
3512         }
3513         next unless is_orig_file $b, srcfn $upstreamversion,'';
3514         printdebug "QF linkorigs $b, $f Y\n";
3515         link_ltarget $f, $b or die "$b $!";
3516         $fn->($b);
3517     }
3518 }
3519
3520 sub quilt_fixup_delete_pc () {
3521     runcmd @git, qw(rm -rqf .pc);
3522     commit_admin "Commit removal of .pc (quilt series tracking data)";
3523 }
3524
3525 sub quilt_fixup_singlepatch ($$$) {
3526     my ($clogp, $headref, $upstreamversion) = @_;
3527
3528     progress "starting quiltify (single-debian-patch)";
3529
3530     # dpkg-source --commit generates new patches even if
3531     # single-debian-patch is in debian/source/options.  In order to
3532     # get it to generate debian/patches/debian-changes, it is
3533     # necessary to build the source package.
3534
3535     quilt_fixup_linkorigs($upstreamversion, sub { });
3536     quilt_fixup_mkwork($headref);
3537
3538     rmtree("debian/patches");
3539
3540     runcmd @dpkgsource, qw(-b .);
3541     chdir "..";
3542     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3543     rename srcfn("$upstreamversion", "/debian/patches"), 
3544            "work/debian/patches";
3545
3546     chdir "work";
3547     commit_quilty_patch();
3548 }
3549
3550 sub quilt_make_fake_dsc ($) {
3551     my ($upstreamversion) = @_;
3552
3553     my $fakeversion="$upstreamversion-~~DGITFAKE";
3554
3555     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3556     print $fakedsc <<END or die $!;
3557 Format: 3.0 (quilt)
3558 Source: $package
3559 Version: $fakeversion
3560 Files:
3561 END
3562
3563     my $dscaddfile=sub {
3564         my ($b) = @_;
3565         
3566         my $md = new Digest::MD5;
3567
3568         my $fh = new IO::File $b, '<' or die "$b $!";
3569         stat $fh or die $!;
3570         my $size = -s _;
3571
3572         $md->addfile($fh);
3573         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3574     };
3575
3576     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3577
3578     my @files=qw(debian/source/format debian/rules
3579                  debian/control debian/changelog);
3580     foreach my $maybe (qw(debian/patches debian/source/options
3581                           debian/tests/control)) {
3582         next unless stat_exists "../../../$maybe";
3583         push @files, $maybe;
3584     }
3585
3586     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3587     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3588
3589     $dscaddfile->($debtar);
3590     close $fakedsc or die $!;
3591 }
3592
3593 sub quilt_check_splitbrain_cache ($$) {
3594     my ($headref, $upstreamversion) = @_;
3595     # Called only if we are in (potentially) split brain mode.
3596     # Called in $ud.
3597     # Computes the cache key and looks in the cache.
3598     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3599
3600     my $splitbrain_cachekey;
3601     
3602     progress
3603  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3604     # we look in the reflog of dgit-intern/quilt-cache
3605     # we look for an entry whose message is the key for the cache lookup
3606     my @cachekey = (qw(dgit), $our_version);
3607     push @cachekey, $upstreamversion;
3608     push @cachekey, $quilt_mode;
3609     push @cachekey, $headref;
3610
3611     push @cachekey, hashfile('fake.dsc');
3612
3613     my $srcshash = Digest::SHA->new(256);
3614     my %sfs = ( %INC, '$0(dgit)' => $0 );
3615     foreach my $sfk (sort keys %sfs) {
3616         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3617         $srcshash->add($sfk,"  ");
3618         $srcshash->add(hashfile($sfs{$sfk}));
3619         $srcshash->add("\n");
3620     }
3621     push @cachekey, $srcshash->hexdigest();
3622     $splitbrain_cachekey = "@cachekey";
3623
3624     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3625                $splitbraincache);
3626     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3627     debugcmd "|(probably)",@cmd;
3628     my $child = open GC, "-|";  defined $child or die $!;
3629     if (!$child) {
3630         chdir '../../..' or die $!;
3631         if (!stat ".git/logs/refs/$splitbraincache") {
3632             $! == ENOENT or die $!;
3633             printdebug ">(no reflog)\n";
3634             exit 0;
3635         }
3636         exec @cmd; die $!;
3637     }
3638     while (<GC>) {
3639         chomp;
3640         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3641         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3642             
3643         my $cachehit = $1;
3644         quilt_fixup_mkwork($headref);
3645         if ($cachehit ne $headref) {
3646             progress "dgit view: found cached (commit id $cachehit)";
3647             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3648             $split_brain = 1;
3649             return ($cachehit, $splitbrain_cachekey);
3650         }
3651         progress "dgit view: found cached, no changes required";
3652         return ($headref, $splitbrain_cachekey);
3653     }
3654     die $! if GC->error;
3655     failedcmd unless close GC;
3656
3657     printdebug "splitbrain cache miss\n";
3658     return (undef, $splitbrain_cachekey);
3659 }
3660
3661 sub quilt_fixup_multipatch ($$$) {
3662     my ($clogp, $headref, $upstreamversion) = @_;
3663
3664     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3665
3666     # Our objective is:
3667     #  - honour any existing .pc in case it has any strangeness
3668     #  - determine the git commit corresponding to the tip of
3669     #    the patch stack (if there is one)
3670     #  - if there is such a git commit, convert each subsequent
3671     #    git commit into a quilt patch with dpkg-source --commit
3672     #  - otherwise convert all the differences in the tree into
3673     #    a single git commit
3674     #
3675     # To do this we:
3676
3677     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3678     # dgit would include the .pc in the git tree.)  If there isn't
3679     # one, we need to generate one by unpacking the patches that we
3680     # have.
3681     #
3682     # We first look for a .pc in the git tree.  If there is one, we
3683     # will use it.  (This is not the normal case.)
3684     #
3685     # Otherwise need to regenerate .pc so that dpkg-source --commit
3686     # can work.  We do this as follows:
3687     #     1. Collect all relevant .orig from parent directory
3688     #     2. Generate a debian.tar.gz out of
3689     #         debian/{patches,rules,source/format,source/options}
3690     #     3. Generate a fake .dsc containing just these fields:
3691     #          Format Source Version Files
3692     #     4. Extract the fake .dsc
3693     #        Now the fake .dsc has a .pc directory.
3694     # (In fact we do this in every case, because in future we will
3695     # want to search for a good base commit for generating patches.)
3696     #
3697     # Then we can actually do the dpkg-source --commit
3698     #     1. Make a new working tree with the same object
3699     #        store as our main tree and check out the main
3700     #        tree's HEAD.
3701     #     2. Copy .pc from the fake's extraction, if necessary
3702     #     3. Run dpkg-source --commit
3703     #     4. If the result has changes to debian/, then
3704     #          - git-add them them
3705     #          - git-add .pc if we had a .pc in-tree
3706     #          - git-commit
3707     #     5. If we had a .pc in-tree, delete it, and git-commit
3708     #     6. Back in the main tree, fast forward to the new HEAD
3709
3710     # Another situation we may have to cope with is gbp-style
3711     # patches-unapplied trees.
3712     #
3713     # We would want to detect these, so we know to escape into
3714     # quilt_fixup_gbp.  However, this is in general not possible.
3715     # Consider a package with a one patch which the dgit user reverts
3716     # (with git-revert or the moral equivalent).
3717     #
3718     # That is indistinguishable in contents from a patches-unapplied
3719     # tree.  And looking at the history to distinguish them is not
3720     # useful because the user might have made a confusing-looking git
3721     # history structure (which ought to produce an error if dgit can't
3722     # cope, not a silent reintroduction of an unwanted patch).
3723     #
3724     # So gbp users will have to pass an option.  But we can usually
3725     # detect their failure to do so: if the tree is not a clean
3726     # patches-applied tree, quilt linearisation fails, but the tree
3727     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3728     # they want --quilt=unapplied.
3729     #
3730     # To help detect this, when we are extracting the fake dsc, we
3731     # first extract it with --skip-patches, and then apply the patches
3732     # afterwards with dpkg-source --before-build.  That lets us save a
3733     # tree object corresponding to .origs.
3734
3735     my $splitbrain_cachekey;
3736
3737     quilt_make_fake_dsc($upstreamversion);
3738
3739     if (quiltmode_splitbrain()) {
3740         my $cachehit;
3741         ($cachehit, $splitbrain_cachekey) =
3742             quilt_check_splitbrain_cache($headref, $upstreamversion);
3743         return if $cachehit;