chiark / gitweb /
dgit: Add a couple of comments
[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.  If there is nothing in the archive,
1807     #  leaves lrref alone and returns 0.
1808     get_archive_dsc();
1809
1810     if ($dsc) {
1811         foreach my $field (@ourdscfield) {
1812             $dsc_hash = $dsc->{$field};
1813             last if defined $dsc_hash;
1814         }
1815         if (defined $dsc_hash) {
1816             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1817             $dsc_hash = $&;
1818             progress "last upload to archive specified git hash";
1819         } else {
1820             progress "last upload to archive has NO git hash";
1821         }
1822     } else {
1823         progress "no version available from the archive";
1824     }
1825
1826     # If the archive's .dsc has a Dgit field, there are three
1827     # relevant git commitids we need to choose between and/or merge
1828     # together:
1829     #   1. $dsc_hash: the Dgit field from the archive
1830     #   2. $lastpush_hash: the suite branch on the dgit git server
1831     #   3. $lastfetch_hash: our local tracking brach for the suite
1832     #
1833     # These may all be distinct and need not be in any fast forward
1834     # relationship:
1835     #
1836     # If the dsc was pushed to this suite, then the server suite
1837     # branch will have been updated; but it might have been pushed to
1838     # a different suite and copied by the archive.  Conversely a more
1839     # recent version may have been pushed with dgit but not appeared
1840     # in the archive (yet).
1841     #
1842     # $lastfetch_hash may be awkward because archive imports
1843     # (particularly, imports of Dgit-less .dscs) are performed only as
1844     # needed on individual clients, so different clients may perform a
1845     # different subset of them - and these imports are only made
1846     # public during push.  So $lastfetch_hash may represent a set of
1847     # imports different to a subsequent upload by a different dgit
1848     # client.
1849     #
1850     # Our approach is as follows:
1851     #
1852     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
1853     # descendant of $dsc_hash, then it was pushed by a dgit user who
1854     # had based their work on $dsc_hash, so we should prefer it.
1855     # Otherwise, $dsc_hash was installed into this suite in the
1856     # archive other than by a dgit push, and (necessarily) after the
1857     # last dgit push into that suite (since a dgit push would have
1858     # been descended from the dgit server git branch); thus, in that
1859     # case, we prefer the archive's version (and produce a
1860     # pseudo-merge to overwrite the dgit server git branch).
1861     #
1862     # (If there is no Dgit field in the archive's .dsc then
1863     # generate_commit_from_dsc uses the version numbers to decide
1864     # whether the suite branch or the archive is newer.  If the suite
1865     # branch is newer it ignores the archive's .dsc; otherwise it
1866     # generates an import of the .dsc, and produces a pseudo-merge to
1867     # overwrite the suite branch with the archive contents.)
1868     #
1869     # The outcome of that part of the algorithm is the `public view',
1870     # and is same for all dgit clients: it does not depend on any
1871     # unpublished history in the local tracking branch.
1872     #
1873     # As between the public view and the local tracking branch: The
1874     # local tracking branch is only updated by dgit fetch, and
1875     # whenever dgit fetch runs it includes the public view in the
1876     # local tracking branch.  Therefore if the public view is not
1877     # descended from the local tracking branch, the local tracking
1878     # branch must contain history which was imported from the archive
1879     # but never pushed; and, its tip is now out of date.  So, we make
1880     # a pseudo-merge to overwrite the old imports and stitch the old
1881     # history in.
1882     #
1883     # Finally: we do not necessarily reify the public view (as
1884     # described above).  This is so that we do not end up stacking two
1885     # pseudo-merges.  So what we actually do is figure out the inputs
1886     # to any public view psuedo-merge and put them in @mergeinputs.
1887
1888     my @mergeinputs;
1889     # $mergeinputs[]{Commit}
1890     # $mergeinputs[]{Info}
1891     # $mergeinputs[0] is the one whose tree we use
1892     # @mergeinputs is in the order we use in the actual commit)
1893     #
1894     # Also:
1895     # $mergeinputs[]{Message} is a commit message to use
1896     # $mergeinputs[]{ReverseParents} if def specifies that parent
1897     #                                list should be in opposite order
1898     # Such an entry has no Commit or Info.  It applies only when found
1899     # in the last entry.  (This ugliness is to support making
1900     # identical imports to previous dgit versions.)
1901
1902     my $lastpush_hash = git_get_ref(lrfetchref());
1903     printdebug "previous reference hash=$lastpush_hash\n";
1904     $lastpush_mergeinput = $lastpush_hash && {
1905         Commit => $lastpush_hash,
1906         Info => "dgit suite branch on dgit git server",
1907     };
1908
1909     my $lastfetch_hash = git_get_ref(lrref());
1910     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
1911     my $lastfetch_mergeinput = $lastfetch_hash && {
1912         Commit => $lastfetch_hash,
1913         Info => "dgit client's archive history view",
1914     };
1915
1916     my $dsc_mergeinput = $dsc_hash && {
1917         Commit => $dsc_hash,
1918         Info => "Dgit field in .dsc from archive",
1919     };
1920
1921     my $cwd = getcwd();
1922     my $del_lrfetchrefs = sub {
1923         changedir $cwd;
1924         my $gur;
1925         printdebug "del_lrfetchrefs\n";
1926         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
1927             my $objid = $lrfetchrefs_d{$fullrefname};
1928             printdebug "del_lrfetchrefs: $fullrefname=$objid.\n";
1929             if (!$gur) {
1930                 $gur ||= new IO::Handle;
1931                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
1932             }
1933             printf $gur "delete %s %s\n", $fullrefname, $objid;
1934         }
1935         if ($gur) {
1936             close $gur or failedcmd "git update-ref delete lrfetchrefs";
1937         }
1938     };
1939
1940     if (defined $dsc_hash) {
1941         fail "missing remote git history even though dsc has hash -".
1942             " could not find ref ".rref()." at ".access_giturl()
1943             unless $lastpush_hash;
1944         ensure_we_have_orig();
1945         if ($dsc_hash eq $lastpush_hash) {
1946             @mergeinputs = $dsc_mergeinput
1947         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1948             print STDERR <<END or die $!;
1949
1950 Git commit in archive is behind the last version allegedly pushed/uploaded.
1951 Commit referred to by archive: $dsc_hash
1952 Last version pushed with dgit: $lastpush_hash
1953 $later_warning_msg
1954 END
1955             @mergeinputs = ($lastpush_mergeinput);
1956         } else {
1957             # Archive has .dsc which is not a descendant of the last dgit
1958             # push.  This can happen if the archive moves .dscs about.
1959             # Just follow its lead.
1960             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
1961                 progress "archive .dsc names newer git commit";
1962                 @mergeinputs = ($dsc_mergeinput);
1963             } else {
1964                 progress "archive .dsc names other git commit, fixing up";
1965                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
1966             }
1967         }
1968     } elsif ($dsc) {
1969         @mergeinputs = generate_commits_from_dsc();
1970         # We have just done an import.  Now, our import algorithm might
1971         # have been improved.  But even so we do not want to generate
1972         # a new different import of the same package.  So if the
1973         # version numbers are the same, just use our existing version.
1974         # If the version numbers are different, the archive has changed
1975         # (perhaps, rewound).
1976         if ($lastfetch_mergeinput &&
1977             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
1978                               (mergeinfo_version $mergeinputs[0]) )) {
1979             @mergeinputs = ($lastfetch_mergeinput);
1980         }
1981     } elsif ($lastpush_hash) {
1982         # only in git, not in the archive yet
1983         @mergeinputs = ($lastpush_mergeinput);
1984         print STDERR <<END or die $!;
1985
1986 Package not found in the archive, but has allegedly been pushed using dgit.
1987 $later_warning_msg
1988 END
1989     } else {
1990         printdebug "nothing found!\n";
1991         if (defined $skew_warning_vsn) {
1992             print STDERR <<END or die $!;
1993
1994 Warning: relevant archive skew detected.
1995 Archive allegedly contains $skew_warning_vsn
1996 But we were not able to obtain any version from the archive or git.
1997
1998 END
1999         }
2000         unshift @end, $del_lrfetchrefs;
2001         return 0;
2002     }
2003
2004     if ($lastfetch_hash &&
2005         !grep {
2006             my $h = $_->{Commit};
2007             $h and is_fast_fwd($lastfetch_hash, $h);
2008             # If true, one of the existing parents of this commit
2009             # is a descendant of the $lastfetch_hash, so we'll
2010             # be ff from that automatically.
2011         } @mergeinputs
2012         ) {
2013         # Otherwise:
2014         push @mergeinputs, $lastfetch_mergeinput;
2015     }
2016
2017     printdebug "fetch mergeinfos:\n";
2018     foreach my $mi (@mergeinputs) {
2019         if ($mi->{Info}) {
2020             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2021         } else {
2022             printdebug sprintf " ReverseParents=%d Message=%s",
2023                 $mi->{ReverseParents}, $mi->{Message};
2024         }
2025     }
2026
2027     my $compat_info= pop @mergeinputs
2028         if $mergeinputs[$#mergeinputs]{Message};
2029
2030     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2031
2032     my $hash;
2033     if (@mergeinputs > 1) {
2034         # here we go, then:
2035         my $tree_commit = $mergeinputs[0]{Commit};
2036
2037         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2038         $tree =~ m/\n\n/;  $tree = $`;
2039         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2040         $tree = $1;
2041
2042         # We use the changelog author of the package in question the
2043         # author of this pseudo-merge.  This is (roughly) correct if
2044         # this commit is simply representing aa non-dgit upload.
2045         # (Roughly because it does not record sponsorship - but we
2046         # don't have sponsorship info because that's in the .changes,
2047         # which isn't in the archivw.)
2048         #
2049         # But, it might be that we are representing archive history
2050         # updates (including in-archive copies).  These are not really
2051         # the responsibility of the person who created the .dsc, but
2052         # there is no-one whose name we should better use.  (The
2053         # author of the .dsc-named commit is clearly worse.)
2054
2055         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2056         my $author = clogp_authline $useclogp;
2057         my $cversion = getfield $useclogp, 'Version';
2058
2059         my $mcf = ".git/dgit/mergecommit";
2060         open MC, ">", $mcf or die "$mcf $!";
2061         print MC <<END or die $!;
2062 tree $tree
2063 END
2064
2065         my @parents = grep { $_->{Commit} } @mergeinputs;
2066         @parents = reverse @parents if $compat_info->{ReverseParents};
2067         print MC <<END or die $! foreach @parents;
2068 parent $_->{Commit}
2069 END
2070
2071         print MC <<END or die $!;
2072 author $author
2073 committer $author
2074
2075 END
2076
2077         if (defined $compat_info->{Message}) {
2078             print MC $compat_info->{Message} or die $!;
2079         } else {
2080             print MC <<END or die $!;
2081 Record $package ($cversion) in archive suite $csuite
2082
2083 Record that
2084 END
2085             my $message_add_info = sub {
2086                 my ($mi) = (@_);
2087                 my $mversion = mergeinfo_version $mi;
2088                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2089                     or die $!;
2090             };
2091
2092             $message_add_info->($mergeinputs[0]);
2093             print MC <<END or die $!;
2094 should be treated as descended from
2095 END
2096             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2097         }
2098
2099         close MC or die $!;
2100         $hash = make_commit $mcf;
2101     } else {
2102         $hash = $mergeinputs[0]{Commit};
2103     }
2104     progress "fetch hash=$hash\n";
2105
2106     my $chkff = sub {
2107         my ($lasth, $what) = @_;
2108         return unless $lasth;
2109         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2110     };
2111
2112     $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2113     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2114
2115     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2116             'DGIT_ARCHIVE', $hash;
2117     cmdoutput @git, qw(log -n2), $hash;
2118     # ... gives git a chance to complain if our commit is malformed
2119
2120     if (defined $skew_warning_vsn) {
2121         mkpath '.git/dgit';
2122         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2123         my $clogf = ".git/dgit/changelog.tmp";
2124         runcmd shell_cmd "exec >$clogf",
2125             @git, qw(cat-file blob), "$hash:debian/changelog";
2126         my $gotclogp = parsechangelog("-l$clogf");
2127         my $got_vsn = getfield $gotclogp, 'Version';
2128         printdebug "SKEW CHECK GOT $got_vsn\n";
2129         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2130             print STDERR <<END or die $!;
2131
2132 Warning: archive skew detected.  Using the available version:
2133 Archive allegedly contains    $skew_warning_vsn
2134 We were able to obtain only   $got_vsn
2135
2136 END
2137         }
2138     }
2139
2140     if ($lastfetch_hash ne $hash) {
2141         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2142         if (act_local()) {
2143             cmdoutput @upd_cmd;
2144         } else {
2145             dryrun_report @upd_cmd;
2146         }
2147     }
2148
2149     lrfetchref_used lrfetchref();
2150
2151     unshift @end, $del_lrfetchrefs;
2152     return 1;
2153 }
2154
2155 sub set_local_git_config ($$) {
2156     my ($k, $v) = @_;
2157     runcmd @git, qw(config), $k, $v;
2158 }
2159
2160 sub setup_mergechangelogs (;$) {
2161     my ($always) = @_;
2162     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2163
2164     my $driver = 'dpkg-mergechangelogs';
2165     my $cb = "merge.$driver";
2166     my $attrs = '.git/info/attributes';
2167     ensuredir '.git/info';
2168
2169     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2170     if (!open ATTRS, "<", $attrs) {
2171         $!==ENOENT or die "$attrs: $!";
2172     } else {
2173         while (<ATTRS>) {
2174             chomp;
2175             next if m{^debian/changelog\s};
2176             print NATTRS $_, "\n" or die $!;
2177         }
2178         ATTRS->error and die $!;
2179         close ATTRS;
2180     }
2181     print NATTRS "debian/changelog merge=$driver\n" or die $!;
2182     close NATTRS;
2183
2184     set_local_git_config "$cb.name", 'debian/changelog merge driver';
2185     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2186
2187     rename "$attrs.new", "$attrs" or die "$attrs: $!";
2188 }
2189
2190 sub setup_useremail (;$) {
2191     my ($always) = @_;
2192     return unless $always || access_cfg_bool(1, 'setup-useremail');
2193
2194     my $setup = sub {
2195         my ($k, $envvar) = @_;
2196         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2197         return unless defined $v;
2198         set_local_git_config "user.$k", $v;
2199     };
2200
2201     $setup->('email', 'DEBEMAIL');
2202     $setup->('name', 'DEBFULLNAME');
2203 }
2204
2205 sub setup_new_tree () {
2206     setup_mergechangelogs();
2207     setup_useremail();
2208 }
2209
2210 sub clone ($) {
2211     my ($dstdir) = @_;
2212     canonicalise_suite();
2213     badusage "dry run makes no sense with clone" unless act_local();
2214     my $hasgit = check_for_git();
2215     mkdir $dstdir or fail "create \`$dstdir': $!";
2216     changedir $dstdir;
2217     runcmd @git, qw(init -q);
2218     my $giturl = access_giturl(1);
2219     if (defined $giturl) {
2220         open H, "> .git/HEAD" or die $!;
2221         print H "ref: ".lref()."\n" or die $!;
2222         close H or die $!;
2223         runcmd @git, qw(remote add), 'origin', $giturl;
2224     }
2225     if ($hasgit) {
2226         progress "fetching existing git history";
2227         git_fetch_us();
2228         runcmd_ordryrun_local @git, qw(fetch origin);
2229     } else {
2230         progress "starting new git history";
2231     }
2232     fetch_from_archive() or no_such_package;
2233     my $vcsgiturl = $dsc->{'Vcs-Git'};
2234     if (length $vcsgiturl) {
2235         $vcsgiturl =~ s/\s+-b\s+\S+//g;
2236         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2237     }
2238     setup_new_tree();
2239     runcmd @git, qw(reset --hard), lrref();
2240     printdone "ready for work in $dstdir";
2241 }
2242
2243 sub fetch () {
2244     if (check_for_git()) {
2245         git_fetch_us();
2246     }
2247     fetch_from_archive() or no_such_package();
2248     printdone "fetched into ".lrref();
2249 }
2250
2251 sub pull () {
2252     fetch();
2253     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2254         lrref();
2255     printdone "fetched to ".lrref()." and merged into HEAD";
2256 }
2257
2258 sub check_not_dirty () {
2259     foreach my $f (qw(local-options local-patch-header)) {
2260         if (stat_exists "debian/source/$f") {
2261             fail "git tree contains debian/source/$f";
2262         }
2263     }
2264
2265     return if $ignoredirty;
2266
2267     my @cmd = (@git, qw(diff --quiet HEAD));
2268     debugcmd "+",@cmd;
2269     $!=0; $?=-1; system @cmd;
2270     return if !$?;
2271     if ($?==256) {
2272         fail "working tree is dirty (does not match HEAD)";
2273     } else {
2274         failedcmd @cmd;
2275     }
2276 }
2277
2278 sub commit_admin ($) {
2279     my ($m) = @_;
2280     progress "$m";
2281     runcmd_ordryrun_local @git, qw(commit -m), $m;
2282 }
2283
2284 sub commit_quilty_patch () {
2285     my $output = cmdoutput @git, qw(status --porcelain);
2286     my %adds;
2287     foreach my $l (split /\n/, $output) {
2288         next unless $l =~ m/\S/;
2289         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2290             $adds{$1}++;
2291         }
2292     }
2293     delete $adds{'.pc'}; # if there wasn't one before, don't add it
2294     if (!%adds) {
2295         progress "nothing quilty to commit, ok.";
2296         return;
2297     }
2298     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2299     runcmd_ordryrun_local @git, qw(add -f), @adds;
2300     commit_admin "Commit Debian 3.0 (quilt) metadata";
2301 }
2302
2303 sub get_source_format () {
2304     my %options;
2305     if (open F, "debian/source/options") {
2306         while (<F>) {
2307             next if m/^\s*\#/;
2308             next unless m/\S/;
2309             s/\s+$//; # ignore missing final newline
2310             if (m/\s*\#\s*/) {
2311                 my ($k, $v) = ($`, $'); #');
2312                 $v =~ s/^"(.*)"$/$1/;
2313                 $options{$k} = $v;
2314             } else {
2315                 $options{$_} = 1;
2316             }
2317         }
2318         F->error and die $!;
2319         close F;
2320     } else {
2321         die $! unless $!==&ENOENT;
2322     }
2323
2324     if (!open F, "debian/source/format") {
2325         die $! unless $!==&ENOENT;
2326         return '';
2327     }
2328     $_ = <F>;
2329     F->error and die $!;
2330     chomp;
2331     return ($_, \%options);
2332 }
2333
2334 sub madformat ($) {
2335     my ($format) = @_;
2336     return 0 unless $format eq '3.0 (quilt)';
2337     our $quilt_mode_warned;
2338     if ($quilt_mode eq 'nocheck') {
2339         progress "Not doing any fixup of \`$format' due to".
2340             " ----no-quilt-fixup or --quilt=nocheck"
2341             unless $quilt_mode_warned++;
2342         return 0;
2343     }
2344     progress "Format \`$format', need to check/update patch stack"
2345         unless $quilt_mode_warned++;
2346     return 1;
2347 }
2348
2349 sub push_parse_changelog ($) {
2350     my ($clogpfn) = @_;
2351
2352     my $clogp = Dpkg::Control::Hash->new();
2353     $clogp->load($clogpfn) or die;
2354
2355     $package = getfield $clogp, 'Source';
2356     my $cversion = getfield $clogp, 'Version';
2357     my $tag = debiantag($cversion, access_basedistro);
2358     runcmd @git, qw(check-ref-format), $tag;
2359
2360     my $dscfn = dscfn($cversion);
2361
2362     return ($clogp, $cversion, $dscfn);
2363 }
2364
2365 sub push_parse_dsc ($$$) {
2366     my ($dscfn,$dscfnwhat, $cversion) = @_;
2367     $dsc = parsecontrol($dscfn,$dscfnwhat);
2368     my $dversion = getfield $dsc, 'Version';
2369     my $dscpackage = getfield $dsc, 'Source';
2370     ($dscpackage eq $package && $dversion eq $cversion) or
2371         fail "$dscfn is for $dscpackage $dversion".
2372             " but debian/changelog is for $package $cversion";
2373 }
2374
2375 sub push_tagwants ($$$$) {
2376     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2377     my @tagwants;
2378     push @tagwants, {
2379         TagFn => \&debiantag,
2380         Objid => $dgithead,
2381         TfSuffix => '',
2382         View => 'dgit',
2383     };
2384     if (defined $maintviewhead) {
2385         push @tagwants, {
2386             TagFn => \&debiantag_maintview,
2387             Objid => $maintviewhead,
2388             TfSuffix => '-maintview',
2389             View => 'maint',
2390         };
2391     }
2392     foreach my $tw (@tagwants) {
2393         $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2394         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2395     }
2396     return @tagwants;
2397 }
2398
2399 sub push_mktags ($$ $$ $) {
2400     my ($clogp,$dscfn,
2401         $changesfile,$changesfilewhat,
2402         $tagwants) = @_;
2403
2404     die unless $tagwants->[0]{View} eq 'dgit';
2405
2406     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2407     $dsc->save("$dscfn.tmp") or die $!;
2408
2409     my $changes = parsecontrol($changesfile,$changesfilewhat);
2410     foreach my $field (qw(Source Distribution Version)) {
2411         $changes->{$field} eq $clogp->{$field} or
2412             fail "changes field $field \`$changes->{$field}'".
2413                 " does not match changelog \`$clogp->{$field}'";
2414     }
2415
2416     my $cversion = getfield $clogp, 'Version';
2417     my $clogsuite = getfield $clogp, 'Distribution';
2418
2419     # We make the git tag by hand because (a) that makes it easier
2420     # to control the "tagger" (b) we can do remote signing
2421     my $authline = clogp_authline $clogp;
2422     my $delibs = join(" ", "",@deliberatelies);
2423     my $declaredistro = access_basedistro();
2424
2425     my $mktag = sub {
2426         my ($tw) = @_;
2427         my $tfn = $tw->{Tfn};
2428         my $head = $tw->{Objid};
2429         my $tag = $tw->{Tag};
2430
2431         open TO, '>', $tfn->('.tmp') or die $!;
2432         print TO <<END or die $!;
2433 object $head
2434 type commit
2435 tag $tag
2436 tagger $authline
2437
2438 END
2439         if ($tw->{View} eq 'dgit') {
2440             print TO <<END or die $!;
2441 $package release $cversion for $clogsuite ($csuite) [dgit]
2442 [dgit distro=$declaredistro$delibs]
2443 END
2444             foreach my $ref (sort keys %previously) {
2445                 print TO <<END or die $!;
2446 [dgit previously:$ref=$previously{$ref}]
2447 END
2448             }
2449         } elsif ($tw->{View} eq 'maint') {
2450             print TO <<END or die $!;
2451 $package release $cversion for $clogsuite ($csuite)
2452 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2453 END
2454         } else {
2455             die Dumper($tw)."?";
2456         }
2457
2458         close TO or die $!;
2459
2460         my $tagobjfn = $tfn->('.tmp');
2461         if ($sign) {
2462             if (!defined $keyid) {
2463                 $keyid = access_cfg('keyid','RETURN-UNDEF');
2464             }
2465             if (!defined $keyid) {
2466                 $keyid = getfield $clogp, 'Maintainer';
2467             }
2468             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2469             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2470             push @sign_cmd, qw(-u),$keyid if defined $keyid;
2471             push @sign_cmd, $tfn->('.tmp');
2472             runcmd_ordryrun @sign_cmd;
2473             if (act_scary()) {
2474                 $tagobjfn = $tfn->('.signed.tmp');
2475                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
2476                     $tfn->('.tmp'), $tfn->('.tmp.asc');
2477             }
2478         }
2479         return $tagobjfn;
2480     };
2481
2482     my @r = map { $mktag->($_); } @$tagwants;
2483     return @r;
2484 }
2485
2486 sub sign_changes ($) {
2487     my ($changesfile) = @_;
2488     if ($sign) {
2489         my @debsign_cmd = @debsign;
2490         push @debsign_cmd, "-k$keyid" if defined $keyid;
2491         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
2492         push @debsign_cmd, $changesfile;
2493         runcmd_ordryrun @debsign_cmd;
2494     }
2495 }
2496
2497 sub dopush () {
2498     printdebug "actually entering push\n";
2499
2500     supplementary_message(<<'END');
2501 Push failed, while checking state of the archive.
2502 You can retry the push, after fixing the problem, if you like.
2503 END
2504     if (check_for_git()) {
2505         git_fetch_us();
2506     }
2507     my $forceflag = '';
2508     if (fetch_from_archive()) {
2509         if (is_fast_fwd(lrref(), 'HEAD')) {
2510             # ok
2511         } elsif (deliberately_not_fast_forward) {
2512             $forceflag = '+';
2513         } else {
2514             fail "dgit push: HEAD is not a descendant".
2515                 " of the archive's version.\n".
2516                 "dgit: To overwrite its contents,".
2517                 " use git merge -s ours ".lrref().".\n".
2518                 "dgit: To rewind history, if permitted by the archive,".
2519                 " use --deliberately-not-fast-forward";
2520         }
2521     } else {
2522         $new_package or
2523             fail "package appears to be new in this suite;".
2524                 " if this is intentional, use --new";
2525     }
2526
2527     supplementary_message(<<'END');
2528 Push failed, while preparing your push.
2529 You can retry the push, after fixing the problem, if you like.
2530 END
2531
2532     need_tagformat 'new', "quilt mode $quilt_mode"
2533         if quiltmode_splitbrain;
2534
2535     prep_ud();
2536
2537     access_giturl(); # check that success is vaguely likely
2538     select_tagformat();
2539
2540     my $clogpfn = ".git/dgit/changelog.822.tmp";
2541     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
2542
2543     responder_send_file('parsed-changelog', $clogpfn);
2544
2545     my ($clogp, $cversion, $dscfn) =
2546         push_parse_changelog("$clogpfn");
2547
2548     my $dscpath = "$buildproductsdir/$dscfn";
2549     stat_exists $dscpath or
2550         fail "looked for .dsc $dscfn, but $!;".
2551             " maybe you forgot to build";
2552
2553     responder_send_file('dsc', $dscpath);
2554
2555     push_parse_dsc($dscpath, $dscfn, $cversion);
2556
2557     my $format = getfield $dsc, 'Format';
2558     printdebug "format $format\n";
2559
2560     my $actualhead = git_rev_parse('HEAD');
2561     my $dgithead = $actualhead;
2562     my $maintviewhead = undef;
2563
2564     if (madformat($format)) {
2565         # user might have not used dgit build, so maybe do this now:
2566         if (quiltmode_splitbrain()) {
2567             my $upstreamversion = $clogp->{Version};
2568             $upstreamversion =~ s/-[^-]*$//;
2569             changedir $ud;
2570             quilt_make_fake_dsc($upstreamversion);
2571             my ($dgitview, $cachekey) =
2572                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
2573             $dgitview or fail
2574  "--quilt=$quilt_mode but no cached dgit view:
2575  perhaps tree changed since dgit build[-source] ?";
2576             $split_brain = 1;
2577             $dgithead = $dgitview;
2578             $maintviewhead = $actualhead;
2579             changedir '../../../..';
2580             prep_ud(); # so _only_subdir() works, below
2581         } else {
2582             commit_quilty_patch();
2583         }
2584     }
2585
2586     check_not_dirty();
2587     changedir $ud;
2588     progress "checking that $dscfn corresponds to HEAD";
2589     runcmd qw(dpkg-source -x --),
2590         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2591     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2592     check_for_vendor_patches() if madformat($dsc->{format});
2593     changedir '../../../..';
2594     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2595     my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
2596     debugcmd "+",@diffcmd;
2597     $!=0; $?=-1;
2598     my $r = system @diffcmd;
2599     if ($r) {
2600         if ($r==256) {
2601             fail "$dscfn specifies a different tree to your HEAD commit;".
2602                 " perhaps you forgot to build".
2603                 ($diffopt eq '--exit-code' ? "" :
2604                  " (run with -D to see full diff output)");
2605         } else {
2606             failedcmd @diffcmd;
2607         }
2608     }
2609     if (!$changesfile) {
2610         my $pat = changespat $cversion;
2611         my @cs = glob "$buildproductsdir/$pat";
2612         fail "failed to find unique changes file".
2613             " (looked for $pat in $buildproductsdir);".
2614             " perhaps you need to use dgit -C"
2615             unless @cs==1;
2616         ($changesfile) = @cs;
2617     } else {
2618         $changesfile = "$buildproductsdir/$changesfile";
2619     }
2620
2621     # Checks complete, we're going to try and go ahead:
2622
2623     responder_send_file('changes',$changesfile);
2624     responder_send_command("param head $dgithead");
2625     responder_send_command("param csuite $csuite");
2626     responder_send_command("param tagformat $tagformat");
2627     if (quiltmode_splitbrain) {
2628         die unless ($protovsn//4) >= 4;
2629         responder_send_command("param maint-view $maintviewhead");
2630     }
2631
2632     if (deliberately_not_fast_forward) {
2633         git_for_each_ref(lrfetchrefs, sub {
2634             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2635             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2636             responder_send_command("previously $rrefname=$objid");
2637             $previously{$rrefname} = $objid;
2638         });
2639     }
2640
2641     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
2642                                  ".git/dgit/tag");
2643     my @tagobjfns;
2644
2645     supplementary_message(<<'END');
2646 Push failed, while signing the tag.
2647 You can retry the push, after fixing the problem, if you like.
2648 END
2649     # If we manage to sign but fail to record it anywhere, it's fine.
2650     if ($we_are_responder) {
2651         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
2652         responder_receive_files('signed-tag', @tagobjfns);
2653     } else {
2654         @tagobjfns = push_mktags($clogp,$dscpath,
2655                               $changesfile,$changesfile,
2656                               \@tagwants);
2657     }
2658     supplementary_message(<<'END');
2659 Push failed, *after* signing the tag.
2660 If you want to try again, you should use a new version number.
2661 END
2662
2663     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
2664
2665     foreach my $tw (@tagwants) {
2666         my $tag = $tw->{Tag};
2667         my $tagobjfn = $tw->{TagObjFn};
2668         my $tag_obj_hash =
2669             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2670         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2671         runcmd_ordryrun_local
2672             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2673     }
2674
2675     supplementary_message(<<'END');
2676 Push failed, while updating the remote git repository - see messages above.
2677 If you want to try again, you should use a new version number.
2678 END
2679     if (!check_for_git()) {
2680         create_remote_git_repo();
2681     }
2682
2683     my @pushrefs = $forceflag.$dgithead.":".rrref();
2684     foreach my $tw (@tagwants) {
2685         my $view = $tw->{View};
2686         next unless $view eq 'dgit'
2687             or any { $_ eq $view } access_cfg_tagformats();
2688             # ^ $view is "dgit" or "maint" so this looks for "maint"
2689             # in archive supported tagformats.
2690         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
2691     }
2692
2693     runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
2694     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
2695
2696     supplementary_message(<<'END');
2697 Push failed, after updating the remote git repository.
2698 If you want to try again, you must use a new version number.
2699 END
2700     if ($we_are_responder) {
2701         my $dryrunsuffix = act_local() ? "" : ".tmp";
2702         responder_receive_files('signed-dsc-changes',
2703                                 "$dscpath$dryrunsuffix",
2704                                 "$changesfile$dryrunsuffix");
2705     } else {
2706         if (act_local()) {
2707             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2708         } else {
2709             progress "[new .dsc left in $dscpath.tmp]";
2710         }
2711         sign_changes $changesfile;
2712     }
2713
2714     supplementary_message(<<END);
2715 Push failed, while uploading package(s) to the archive server.
2716 You can retry the upload of exactly these same files with dput of:
2717   $changesfile
2718 If that .changes file is broken, you will need to use a new version
2719 number for your next attempt at the upload.
2720 END
2721     my $host = access_cfg('upload-host','RETURN-UNDEF');
2722     my @hostarg = defined($host) ? ($host,) : ();
2723     runcmd_ordryrun @dput, @hostarg, $changesfile;
2724     printdone "pushed and uploaded $cversion";
2725
2726     supplementary_message('');
2727     responder_send_command("complete");
2728 }
2729
2730 sub cmd_clone {
2731     parseopts();
2732     notpushing();
2733     my $dstdir;
2734     badusage "-p is not allowed with clone; specify as argument instead"
2735         if defined $package;
2736     if (@ARGV==1) {
2737         ($package) = @ARGV;
2738     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2739         ($package,$isuite) = @ARGV;
2740     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2741         ($package,$dstdir) = @ARGV;
2742     } elsif (@ARGV==3) {
2743         ($package,$isuite,$dstdir) = @ARGV;
2744     } else {
2745         badusage "incorrect arguments to dgit clone";
2746     }
2747     $dstdir ||= "$package";
2748
2749     if (stat_exists $dstdir) {
2750         fail "$dstdir already exists";
2751     }
2752
2753     my $cwd_remove;
2754     if ($rmonerror && !$dryrun_level) {
2755         $cwd_remove= getcwd();
2756         unshift @end, sub { 
2757             return unless defined $cwd_remove;
2758             if (!chdir "$cwd_remove") {
2759                 return if $!==&ENOENT;
2760                 die "chdir $cwd_remove: $!";
2761             }
2762             if (stat $dstdir) {
2763                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2764             } elsif (!grep { $! == $_ }
2765                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2766             } else {
2767                 print STDERR "check whether to remove $dstdir: $!\n";
2768             }
2769         };
2770     }
2771
2772     clone($dstdir);
2773     $cwd_remove = undef;
2774 }
2775
2776 sub branchsuite () {
2777     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2778     if ($branch =~ m#$lbranch_re#o) {
2779         return $1;
2780     } else {
2781         return undef;
2782     }
2783 }
2784
2785 sub fetchpullargs () {
2786     notpushing();
2787     if (!defined $package) {
2788         my $sourcep = parsecontrol('debian/control','debian/control');
2789         $package = getfield $sourcep, 'Source';
2790     }
2791     if (@ARGV==0) {
2792 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2793         if (!$isuite) {
2794             my $clogp = parsechangelog();
2795             $isuite = getfield $clogp, 'Distribution';
2796         }
2797         canonicalise_suite();
2798         progress "fetching from suite $csuite";
2799     } elsif (@ARGV==1) {
2800         ($isuite) = @ARGV;
2801         canonicalise_suite();
2802     } else {
2803         badusage "incorrect arguments to dgit fetch or dgit pull";
2804     }
2805 }
2806
2807 sub cmd_fetch {
2808     parseopts();
2809     fetchpullargs();
2810     fetch();
2811 }
2812
2813 sub cmd_pull {
2814     parseopts();
2815     fetchpullargs();
2816     pull();
2817 }
2818
2819 sub cmd_push {
2820     parseopts();
2821     pushing();
2822     badusage "-p is not allowed with dgit push" if defined $package;
2823     check_not_dirty();
2824     my $clogp = parsechangelog();
2825     $package = getfield $clogp, 'Source';
2826     my $specsuite;
2827     if (@ARGV==0) {
2828     } elsif (@ARGV==1) {
2829         ($specsuite) = (@ARGV);
2830     } else {
2831         badusage "incorrect arguments to dgit push";
2832     }
2833     $isuite = getfield $clogp, 'Distribution';
2834     if ($new_package) {
2835         local ($package) = $existing_package; # this is a hack
2836         canonicalise_suite();
2837     } else {
2838         canonicalise_suite();
2839     }
2840     if (defined $specsuite &&
2841         $specsuite ne $isuite &&
2842         $specsuite ne $csuite) {
2843             fail "dgit push: changelog specifies $isuite ($csuite)".
2844                 " but command line specifies $specsuite";
2845     }
2846     dopush();
2847 }
2848
2849 #---------- remote commands' implementation ----------
2850
2851 sub cmd_remote_push_build_host {
2852     my ($nrargs) = shift @ARGV;
2853     my (@rargs) = @ARGV[0..$nrargs-1];
2854     @ARGV = @ARGV[$nrargs..$#ARGV];
2855     die unless @rargs;
2856     my ($dir,$vsnwant) = @rargs;
2857     # vsnwant is a comma-separated list; we report which we have
2858     # chosen in our ready response (so other end can tell if they
2859     # offered several)
2860     $debugprefix = ' ';
2861     $we_are_responder = 1;
2862     $us .= " (build host)";
2863
2864     pushing();
2865
2866     open PI, "<&STDIN" or die $!;
2867     open STDIN, "/dev/null" or die $!;
2868     open PO, ">&STDOUT" or die $!;
2869     autoflush PO 1;
2870     open STDOUT, ">&STDERR" or die $!;
2871     autoflush STDOUT 1;
2872
2873     $vsnwant //= 1;
2874     ($protovsn) = grep {
2875         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2876     } @rpushprotovsn_support;
2877
2878     fail "build host has dgit rpush protocol versions ".
2879         (join ",", @rpushprotovsn_support).
2880         " but invocation host has $vsnwant"
2881         unless defined $protovsn;
2882
2883     responder_send_command("dgit-remote-push-ready $protovsn");
2884     rpush_handle_protovsn_bothends();
2885     changedir $dir;
2886     &cmd_push;
2887 }
2888
2889 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2890 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2891 #     a good error message)
2892
2893 sub rpush_handle_protovsn_bothends () {
2894     if ($protovsn < 4) {
2895         need_tagformat 'old', "rpush negotiated protocol $protovsn";
2896     }
2897     select_tagformat();
2898 }
2899
2900 our $i_tmp;
2901
2902 sub i_cleanup {
2903     local ($@, $?);
2904     my $report = i_child_report();
2905     if (defined $report) {
2906         printdebug "($report)\n";
2907     } elsif ($i_child_pid) {
2908         printdebug "(killing build host child $i_child_pid)\n";
2909         kill 15, $i_child_pid;
2910     }
2911     if (defined $i_tmp && !defined $initiator_tempdir) {
2912         changedir "/";
2913         eval { rmtree $i_tmp; };
2914     }
2915 }
2916
2917 END { i_cleanup(); }
2918
2919 sub i_method {
2920     my ($base,$selector,@args) = @_;
2921     $selector =~ s/\-/_/g;
2922     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2923 }
2924
2925 sub cmd_rpush {
2926     pushing();
2927     my $host = nextarg;
2928     my $dir;
2929     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2930         $host = $1;
2931         $dir = $'; #';
2932     } else {
2933         $dir = nextarg;
2934     }
2935     $dir =~ s{^-}{./-};
2936     my @rargs = ($dir);
2937     push @rargs, join ",", @rpushprotovsn_support;
2938     my @rdgit;
2939     push @rdgit, @dgit;
2940     push @rdgit, @ropts;
2941     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2942     push @rdgit, @ARGV;
2943     my @cmd = (@ssh, $host, shellquote @rdgit);
2944     debugcmd "+",@cmd;
2945
2946     if (defined $initiator_tempdir) {
2947         rmtree $initiator_tempdir;
2948         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2949         $i_tmp = $initiator_tempdir;
2950     } else {
2951         $i_tmp = tempdir();
2952     }
2953     $i_child_pid = open2(\*RO, \*RI, @cmd);
2954     changedir $i_tmp;
2955     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2956     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2957     $supplementary_message = '' unless $protovsn >= 3;
2958
2959     fail "rpush negotiated protocol version $protovsn".
2960         " which does not support quilt mode $quilt_mode"
2961         if quiltmode_splitbrain;
2962
2963     rpush_handle_protovsn_bothends();
2964     for (;;) {
2965         my ($icmd,$iargs) = initiator_expect {
2966             m/^(\S+)(?: (.*))?$/;
2967             ($1,$2);
2968         };
2969         i_method "i_resp", $icmd, $iargs;
2970     }
2971 }
2972
2973 sub i_resp_progress ($) {
2974     my ($rhs) = @_;
2975     my $msg = protocol_read_bytes \*RO, $rhs;
2976     progress $msg;
2977 }
2978
2979 sub i_resp_supplementary_message ($) {
2980     my ($rhs) = @_;
2981     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2982 }
2983
2984 sub i_resp_complete {
2985     my $pid = $i_child_pid;
2986     $i_child_pid = undef; # prevents killing some other process with same pid
2987     printdebug "waiting for build host child $pid...\n";
2988     my $got = waitpid $pid, 0;
2989     die $! unless $got == $pid;
2990     die "build host child failed $?" if $?;
2991
2992     i_cleanup();
2993     printdebug "all done\n";
2994     exit 0;
2995 }
2996
2997 sub i_resp_file ($) {
2998     my ($keyword) = @_;
2999     my $localname = i_method "i_localname", $keyword;
3000     my $localpath = "$i_tmp/$localname";
3001     stat_exists $localpath and
3002         badproto \*RO, "file $keyword ($localpath) twice";
3003     protocol_receive_file \*RO, $localpath;
3004     i_method "i_file", $keyword;
3005 }
3006
3007 our %i_param;
3008
3009 sub i_resp_param ($) {
3010     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3011     $i_param{$1} = $2;
3012 }
3013
3014 sub i_resp_previously ($) {
3015     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3016         or badproto \*RO, "bad previously spec";
3017     my $r = system qw(git check-ref-format), $1;
3018     die "bad previously ref spec ($r)" if $r;
3019     $previously{$1} = $2;
3020 }
3021
3022 our %i_wanted;
3023
3024 sub i_resp_want ($) {
3025     my ($keyword) = @_;
3026     die "$keyword ?" if $i_wanted{$keyword}++;
3027     my @localpaths = i_method "i_want", $keyword;
3028     printdebug "[[  $keyword @localpaths\n";
3029     foreach my $localpath (@localpaths) {
3030         protocol_send_file \*RI, $localpath;
3031     }
3032     print RI "files-end\n" or die $!;
3033 }
3034
3035 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3036
3037 sub i_localname_parsed_changelog {
3038     return "remote-changelog.822";
3039 }
3040 sub i_file_parsed_changelog {
3041     ($i_clogp, $i_version, $i_dscfn) =
3042         push_parse_changelog "$i_tmp/remote-changelog.822";
3043     die if $i_dscfn =~ m#/|^\W#;
3044 }
3045
3046 sub i_localname_dsc {
3047     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3048     return $i_dscfn;
3049 }
3050 sub i_file_dsc { }
3051
3052 sub i_localname_changes {
3053     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3054     $i_changesfn = $i_dscfn;
3055     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3056     return $i_changesfn;
3057 }
3058 sub i_file_changes { }
3059
3060 sub i_want_signed_tag {
3061     printdebug Dumper(\%i_param, $i_dscfn);
3062     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3063         && defined $i_param{'csuite'}
3064         or badproto \*RO, "premature desire for signed-tag";
3065     my $head = $i_param{'head'};
3066     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3067
3068     my $maintview = $i_param{'maint-view'};
3069     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3070
3071     select_tagformat();
3072     if ($protovsn >= 4) {
3073         my $p = $i_param{'tagformat'} // '<undef>';
3074         $p eq $tagformat
3075             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3076     }
3077
3078     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3079     $csuite = $&;
3080     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3081
3082     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3083
3084     return
3085         push_mktags $i_clogp, $i_dscfn,
3086             $i_changesfn, 'remote changes',
3087             \@tagwants;
3088 }
3089
3090 sub i_want_signed_dsc_changes {
3091     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3092     sign_changes $i_changesfn;
3093     return ($i_dscfn, $i_changesfn);
3094 }
3095
3096 #---------- building etc. ----------
3097
3098 our $version;
3099 our $sourcechanges;
3100 our $dscfn;
3101
3102 #----- `3.0 (quilt)' handling -----
3103
3104 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3105
3106 sub quiltify_dpkg_commit ($$$;$) {
3107     my ($patchname,$author,$msg, $xinfo) = @_;
3108     $xinfo //= '';
3109
3110     mkpath '.git/dgit';
3111     my $descfn = ".git/dgit/quilt-description.tmp";
3112     open O, '>', $descfn or die "$descfn: $!";
3113     $msg =~ s/\s+$//g;
3114     $msg =~ s/\n/\n /g;
3115     $msg =~ s/^\s+$/ ./mg;
3116     print O <<END or die $!;
3117 Description: $msg
3118 Author: $author
3119 $xinfo
3120 ---
3121
3122 END
3123     close O or die $!;
3124
3125     {
3126         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3127         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3128         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3129         runcmd @dpkgsource, qw(--commit .), $patchname;
3130     }
3131 }
3132
3133 sub quiltify_trees_differ ($$;$$) {
3134     my ($x,$y,$finegrained,$ignorenamesr) = @_;
3135     # returns true iff the two tree objects differ other than in debian/
3136     # with $finegrained,
3137     # returns bitmask 01 - differ in upstream files except .gitignore
3138     #                 02 - differ in .gitignore
3139     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3140     #  is set for each modified .gitignore filename $fn
3141     local $/=undef;
3142     my @cmd = (@git, qw(diff-tree --name-only -z));
3143     push @cmd, qw(-r) if $finegrained;
3144     push @cmd, $x, $y;
3145     my $diffs= cmdoutput @cmd;
3146     my $r = 0;
3147     foreach my $f (split /\0/, $diffs) {
3148         next if $f =~ m#^debian(?:/.*)?$#s;
3149         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3150         $r |= $isignore ? 02 : 01;
3151         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3152     }
3153     printdebug "quiltify_trees_differ $x $y => $r\n";
3154     return $r;
3155 }
3156
3157 sub quiltify_tree_sentinelfiles ($) {
3158     # lists the `sentinel' files present in the tree
3159     my ($x) = @_;
3160     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3161         qw(-- debian/rules debian/control);
3162     $r =~ s/\n/,/g;
3163     return $r;
3164 }
3165
3166 sub quiltify_splitbrain_needed () {
3167     if (!$split_brain) {
3168         progress "dgit view: changes are required...";
3169         runcmd @git, qw(checkout -q -b dgit-view);
3170         $split_brain = 1;
3171     }
3172 }
3173
3174 sub quiltify_splitbrain ($$$$$$) {
3175     my ($clogp, $unapplied, $headref, $diffbits,
3176         $editedignores, $cachekey) = @_;
3177     if ($quilt_mode !~ m/gbp|dpm/) {
3178         # treat .gitignore just like any other upstream file
3179         $diffbits = { %$diffbits };
3180         $_ = !!$_ foreach values %$diffbits;
3181     }
3182     # We would like any commits we generate to be reproducible
3183     my @authline = clogp_authline($clogp);
3184     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
3185     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3186     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
3187         
3188     if ($quilt_mode =~ m/gbp|unapplied/ &&
3189         ($diffbits->{H2O} & 01)) {
3190         my $msg =
3191  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3192  " but git tree differs from orig in upstream files.";
3193         if (!stat_exists "debian/patches") {
3194             $msg .=
3195  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3196         }  
3197         fail $msg;
3198     }
3199     if ($quilt_mode =~ m/gbp|unapplied/ &&
3200         ($diffbits->{O2A} & 01)) { # some patches
3201         quiltify_splitbrain_needed();
3202         progress "dgit view: creating patches-applied version using gbp pq";
3203         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
3204         # gbp pq import creates a fresh branch; push back to dgit-view
3205         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3206         runcmd @git, qw(checkout -q dgit-view);
3207     }
3208     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
3209         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
3210         quiltify_splitbrain_needed();
3211         progress "dgit view: creating patch to represent .gitignore changes";
3212         ensuredir "debian/patches";
3213         my $gipatch = "debian/patches/auto-gitignore";
3214         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
3215         stat GIPATCH or die "$gipatch: $!";
3216         fail "$gipatch already exists; but want to create it".
3217             " to record .gitignore changes" if (stat _)[7];
3218         print GIPATCH <<END or die "$gipatch: $!";
3219 Subject: Update .gitignore from Debian packaging branch
3220
3221 The Debian packaging git branch contains these updates to the upstream
3222 .gitignore file(s).  This patch is autogenerated, to provide these
3223 updates to users of the official Debian archive view of the package.
3224
3225 [dgit version $our_version]
3226 ---
3227 END
3228         close GIPATCH or die "$gipatch: $!";
3229         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
3230             $unapplied, $headref, "--", sort keys %$editedignores;
3231         open SERIES, "+>>", "debian/patches/series" or die $!;
3232         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
3233         my $newline;
3234         defined read SERIES, $newline, 1 or die $!;
3235         print SERIES "\n" or die $! unless $newline eq "\n";
3236         print SERIES "auto-gitignore\n" or die $!;
3237         close SERIES or die  $!;
3238         runcmd @git, qw(add -- debian/patches/series), $gipatch;
3239         commit_admin "Commit patch to update .gitignore";
3240     }
3241
3242     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
3243
3244     changedir '../../../..';
3245     ensuredir ".git/logs/refs/dgit-intern";
3246     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
3247       or die $!;
3248     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
3249         $dgitview;
3250
3251     progress "dgit view: created (commit id $dgitview)";
3252
3253     changedir '.git/dgit/unpack/work';
3254 }
3255
3256 sub quiltify ($$$$) {
3257     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
3258
3259     # Quilt patchification algorithm
3260     #
3261     # We search backwards through the history of the main tree's HEAD
3262     # (T) looking for a start commit S whose tree object is identical
3263     # to to the patch tip tree (ie the tree corresponding to the
3264     # current dpkg-committed patch series).  For these purposes
3265     # `identical' disregards anything in debian/ - this wrinkle is
3266     # necessary because dpkg-source treates debian/ specially.
3267     #
3268     # We can only traverse edges where at most one of the ancestors'
3269     # trees differs (in changes outside in debian/).  And we cannot
3270     # handle edges which change .pc/ or debian/patches.  To avoid
3271     # going down a rathole we avoid traversing edges which introduce
3272     # debian/rules or debian/control.  And we set a limit on the
3273     # number of edges we are willing to look at.
3274     #
3275     # If we succeed, we walk forwards again.  For each traversed edge
3276     # PC (with P parent, C child) (starting with P=S and ending with
3277     # C=T) to we do this:
3278     #  - git checkout C
3279     #  - dpkg-source --commit with a patch name and message derived from C
3280     # After traversing PT, we git commit the changes which
3281     # should be contained within debian/patches.
3282
3283     # The search for the path S..T is breadth-first.  We maintain a
3284     # todo list containing search nodes.  A search node identifies a
3285     # commit, and looks something like this:
3286     #  $p = {
3287     #      Commit => $git_commit_id,
3288     #      Child => $c,                          # or undef if P=T
3289     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
3290     #      Nontrivial => true iff $p..$c has relevant changes
3291     #  };
3292
3293     my @todo;
3294     my @nots;
3295     my $sref_S;
3296     my $max_work=100;
3297     my %considered; # saves being exponential on some weird graphs
3298
3299     my $t_sentinels = quiltify_tree_sentinelfiles $target;
3300
3301     my $not = sub {
3302         my ($search,$whynot) = @_;
3303         printdebug " search NOT $search->{Commit} $whynot\n";
3304         $search->{Whynot} = $whynot;
3305         push @nots, $search;
3306         no warnings qw(exiting);
3307         next;
3308     };
3309
3310     push @todo, {
3311         Commit => $target,
3312     };
3313
3314     while (@todo) {
3315         my $c = shift @todo;
3316         next if $considered{$c->{Commit}}++;
3317
3318         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
3319
3320         printdebug "quiltify investigate $c->{Commit}\n";
3321
3322         # are we done?
3323         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
3324             printdebug " search finished hooray!\n";
3325             $sref_S = $c;
3326             last;
3327         }
3328
3329         if ($quilt_mode eq 'nofix') {
3330             fail "quilt fixup required but quilt mode is \`nofix'\n".
3331                 "HEAD commit $c->{Commit} differs from tree implied by ".
3332                 " debian/patches (tree object $oldtiptree)";
3333         }
3334         if ($quilt_mode eq 'smash') {
3335             printdebug " search quitting smash\n";
3336             last;
3337         }
3338
3339         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
3340         $not->($c, "has $c_sentinels not $t_sentinels")
3341             if $c_sentinels ne $t_sentinels;
3342
3343         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
3344         $commitdata =~ m/\n\n/;
3345         $commitdata =~ $`;
3346         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
3347         @parents = map { { Commit => $_, Child => $c } } @parents;
3348
3349         $not->($c, "root commit") if !@parents;
3350
3351         foreach my $p (@parents) {
3352             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
3353         }
3354         my $ndiffers = grep { $_->{Nontrivial} } @parents;
3355         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
3356
3357         foreach my $p (@parents) {
3358             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
3359
3360             my @cmd= (@git, qw(diff-tree -r --name-only),
3361                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
3362             my $patchstackchange = cmdoutput @cmd;
3363             if (length $patchstackchange) {
3364                 $patchstackchange =~ s/\n/,/g;
3365                 $not->($p, "changed $patchstackchange");
3366             }
3367
3368             printdebug " search queue P=$p->{Commit} ",
3369                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
3370             push @todo, $p;
3371         }
3372     }
3373
3374     if (!$sref_S) {
3375         printdebug "quiltify want to smash\n";
3376
3377         my $abbrev = sub {
3378             my $x = $_[0]{Commit};
3379             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
3380             return $x;
3381         };
3382         my $reportnot = sub {
3383             my ($notp) = @_;
3384             my $s = $abbrev->($notp);
3385             my $c = $notp->{Child};
3386             $s .= "..".$abbrev->($c) if $c;
3387             $s .= ": ".$notp->{Whynot};
3388             return $s;
3389         };
3390         if ($quilt_mode eq 'linear') {
3391             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
3392             foreach my $notp (@nots) {
3393                 print STDERR "$us:  ", $reportnot->($notp), "\n";
3394             }
3395             print STDERR "$us: $_\n" foreach @$failsuggestion;
3396             fail "quilt fixup naive history linearisation failed.\n".
3397  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
3398         } elsif ($quilt_mode eq 'smash') {
3399         } elsif ($quilt_mode eq 'auto') {
3400             progress "quilt fixup cannot be linear, smashing...";
3401         } else {
3402             die "$quilt_mode ?";
3403         }
3404
3405         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
3406         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
3407         my $ncommits = 3;
3408         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
3409
3410         quiltify_dpkg_commit "auto-$version-$target-$time",
3411             (getfield $clogp, 'Maintainer'),
3412             "Automatically generated patch ($clogp->{Version})\n".
3413             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
3414         return;
3415     }
3416
3417     progress "quiltify linearisation planning successful, executing...";
3418
3419     for (my $p = $sref_S;
3420          my $c = $p->{Child};
3421          $p = $p->{Child}) {
3422         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
3423         next unless $p->{Nontrivial};
3424
3425         my $cc = $c->{Commit};
3426
3427         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
3428         $commitdata =~ m/\n\n/ or die "$c ?";
3429         $commitdata = $`;
3430         my $msg = $'; #';
3431         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
3432         my $author = $1;
3433
3434         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
3435
3436         my $title = $1;
3437         my $patchname = $title;
3438         $patchname =~ s/[.:]$//;
3439         $patchname =~ y/ A-Z/-a-z/;
3440         $patchname =~ y/-a-z0-9_.+=~//cd;
3441         $patchname =~ s/^\W/x-$&/;
3442         $patchname = substr($patchname,0,40);
3443         my $index;
3444         for ($index='';
3445              stat "debian/patches/$patchname$index";
3446              $index++) { }
3447         $!==ENOENT or die "$patchname$index $!";
3448
3449         runcmd @git, qw(checkout -q), $cc;
3450
3451         # We use the tip's changelog so that dpkg-source doesn't
3452         # produce complaining messages from dpkg-parsechangelog.  None
3453         # of the information dpkg-source gets from the changelog is
3454         # actually relevant - it gets put into the original message
3455         # which dpkg-source provides our stunt editor, and then
3456         # overwritten.
3457         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
3458
3459         quiltify_dpkg_commit "$patchname$index", $author, $msg,
3460             "X-Dgit-Generated: $clogp->{Version} $cc\n";
3461
3462         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
3463     }
3464
3465     runcmd @git, qw(checkout -q master);
3466 }
3467
3468 sub build_maybe_quilt_fixup () {
3469     my ($format,$fopts) = get_source_format;
3470     return unless madformat $format;
3471     # sigh
3472
3473     check_for_vendor_patches();
3474
3475     my $clogp = parsechangelog();
3476     my $headref = git_rev_parse('HEAD');
3477
3478     prep_ud();
3479     changedir $ud;
3480
3481     my $upstreamversion=$version;
3482     $upstreamversion =~ s/-[^-]*$//;
3483
3484     if ($fopts->{'single-debian-patch'}) {
3485         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
3486     } else {
3487         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
3488     }
3489
3490     die 'bug' if $split_brain && !$need_split_build_invocation;
3491
3492     changedir '../../../..';
3493     runcmd_ordryrun_local
3494         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
3495 }
3496
3497 sub quilt_fixup_mkwork ($) {
3498     my ($headref) = @_;
3499
3500     mkdir "work" or die $!;
3501     changedir "work";
3502     mktree_in_ud_here();
3503     runcmd @git, qw(reset -q --hard), $headref;
3504 }
3505
3506 sub quilt_fixup_linkorigs ($$) {
3507     my ($upstreamversion, $fn) = @_;
3508     # calls $fn->($leafname);
3509
3510     foreach my $f (<../../../../*>) { #/){
3511         my $b=$f; $b =~ s{.*/}{};
3512         {
3513             local ($debuglevel) = $debuglevel-1;
3514             printdebug "QF linkorigs $b, $f ?\n";
3515         }
3516         next unless is_orig_file $b, srcfn $upstreamversion,'';
3517         printdebug "QF linkorigs $b, $f Y\n";
3518         link_ltarget $f, $b or die "$b $!";
3519         $fn->($b);
3520     }
3521 }
3522
3523 sub quilt_fixup_delete_pc () {
3524     runcmd @git, qw(rm -rqf .pc);
3525     commit_admin "Commit removal of .pc (quilt series tracking data)";
3526 }
3527
3528 sub quilt_fixup_singlepatch ($$$) {
3529     my ($clogp, $headref, $upstreamversion) = @_;
3530
3531     progress "starting quiltify (single-debian-patch)";
3532
3533     # dpkg-source --commit generates new patches even if
3534     # single-debian-patch is in debian/source/options.  In order to
3535     # get it to generate debian/patches/debian-changes, it is
3536     # necessary to build the source package.
3537
3538     quilt_fixup_linkorigs($upstreamversion, sub { });
3539     quilt_fixup_mkwork($headref);
3540
3541     rmtree("debian/patches");
3542
3543     runcmd @dpkgsource, qw(-b .);
3544     chdir "..";
3545     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
3546     rename srcfn("$upstreamversion", "/debian/patches"), 
3547            "work/debian/patches";
3548
3549     chdir "work";
3550     commit_quilty_patch();
3551 }
3552
3553 sub quilt_make_fake_dsc ($) {
3554     my ($upstreamversion) = @_;
3555
3556     my $fakeversion="$upstreamversion-~~DGITFAKE";
3557
3558     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3559     print $fakedsc <<END or die $!;
3560 Format: 3.0 (quilt)
3561 Source: $package
3562 Version: $fakeversion
3563 Files:
3564 END
3565
3566     my $dscaddfile=sub {
3567         my ($b) = @_;
3568         
3569         my $md = new Digest::MD5;
3570
3571         my $fh = new IO::File $b, '<' or die "$b $!";
3572         stat $fh or die $!;
3573         my $size = -s _;
3574
3575         $md->addfile($fh);
3576         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3577     };
3578
3579     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3580
3581     my @files=qw(debian/source/format debian/rules
3582                  debian/control debian/changelog);
3583     foreach my $maybe (qw(debian/patches debian/source/options
3584                           debian/tests/control)) {
3585         next unless stat_exists "../../../$maybe";
3586         push @files, $maybe;
3587     }
3588
3589     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3590     runcmd qw(env GZIP=-1n tar -zcf), "./$debtar", qw(-C ../../..), @files;
3591
3592     $dscaddfile->($debtar);
3593     close $fakedsc or die $!;
3594 }
3595
3596 sub quilt_check_splitbrain_cache ($$) {
3597     my ($headref, $upstreamversion) = @_;
3598     # Called only if we are in (potentially) split brain mode.
3599     # Called in $ud.
3600     # Computes the cache key and looks in the cache.
3601     # Returns ($dgit_view_commitid, $cachekey) or (undef, $cachekey)
3602
3603     my $splitbrain_cachekey;
3604     
3605     progress
3606  "dgit: split brain (separate dgit view) may be needed (--quilt=$quilt_mode).";
3607     # we look in the reflog of dgit-intern/quilt-cache
3608     # we look for an entry whose message is the key for the cache lookup
3609     my @cachekey = (qw(dgit), $our_version);
3610     push @cachekey, $upstreamversion;
3611     push @cachekey, $quilt_mode;
3612     push @cachekey, $headref;
3613
3614     push @cachekey, hashfile('fake.dsc');
3615
3616     my $srcshash = Digest::SHA->new(256);
3617     my %sfs = ( %INC, '$0(dgit)' => $0 );
3618     foreach my $sfk (sort keys %sfs) {
3619         next unless m/^\$0\b/ || m{^Debian/Dgit\b};
3620         $srcshash->add($sfk,"  ");
3621         $srcshash->add(hashfile($sfs{$sfk}));
3622         $srcshash->add("\n");
3623     }
3624     push @cachekey, $srcshash->hexdigest();
3625     $splitbrain_cachekey = "@cachekey";
3626
3627     my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3628                $splitbraincache);
3629     printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3630     debugcmd "|(probably)",@cmd;
3631     my $child = open GC, "-|";  defined $child or die $!;
3632     if (!$child) {
3633         chdir '../../..' or die $!;
3634         if (!stat ".git/logs/refs/$splitbraincache") {
3635             $! == ENOENT or die $!;
3636             printdebug ">(no reflog)\n";
3637             exit 0;
3638         }
3639         exec @cmd; die $!;
3640     }
3641     while (<GC>) {
3642         chomp;
3643         printdebug ">| ", $_, "\n" if $debuglevel > 1;
3644         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3645             
3646         my $cachehit = $1;
3647         quilt_fixup_mkwork($headref);
3648         if ($cachehit ne $headref) {
3649             progress "dgit view: found cached (commit id $cachehit)";
3650             runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3651             $split_brain = 1;
3652             return ($cachehit, $splitbrain_cachekey);
3653         }
3654         progress "dgit view: found cached, no changes required";
3655         return ($headref, $splitbrain_cachekey);
3656     }
3657     die $! if GC->error;
3658     failedcmd unless close GC;
3659
3660     printdebug "splitbrain cache miss\n";
3661     return (undef, $splitbrain_cachekey);
3662 }
3663
3664 sub quilt_fixup_multipatch ($$$) {
3665     my ($clogp, $headref, $upstreamversion) = @_;
3666
3667     progress "examining quilt state (multiple patches, $quilt_mode mode)";
3668
3669     # Our objective is:
3670     #  - honour any existing .pc in case it has any strangeness
3671     #  - determine the git commit corresponding to the tip of
3672     #    the patch stack (if there is one)
3673     #  - if there is such a git commit, convert each subsequent
3674     #    git commit into a quilt patch with dpkg-source --commit
3675     #  - otherwise convert all the differences in the tree into
3676     #    a single git commit
3677     #
3678     # To do this we:
3679
3680     # Our git tree doesn't necessarily contain .pc.  (Some versions of
3681     # dgit would include the .pc in the git tree.)  If there isn't
3682     # one, we need to generate one by unpacking the patches that we
3683     # have.
3684     #
3685     # We first look for a .pc in the git tree.  If there is one, we
3686     # will use it.  (This is not the normal case.)
3687     #
3688     # Otherwise need to regenerate .pc so that dpkg-source --commit
3689     # can work.  We do this as follows:
3690     #     1. Collect all relevant .orig from parent directory
3691     #     2. Generate a debian.tar.gz out of
3692     #         debian/{patches,rules,source/format,source/options}
3693     #     3. Generate a fake .dsc containing just these fields:
3694     #          Format Source Version Files
3695     #     4. Extract the fake .dsc
3696     #        Now the fake .dsc has a .pc directory.
3697     # (In fact we do this in every case, because in future we will
3698     # want to search for a good base commit for generating patches.)
3699     #
3700     # Then we can actually do the dpkg-source --commit
3701     #     1. Make a new working tree with the same object
3702     #        store as our main tree and check out the main
3703     #        tree's HEAD.
3704     #     2. Copy .pc from the fake's extraction, if necessary
3705     #     3. Run dpkg-source --commit
3706     #     4. If the result has changes to debian/, then
3707     #          - git-add them them
3708     #          - git-add .pc if we had a .pc in-tree
3709     #          - git-commit
3710     #     5. If we had a .pc in-tree, delete it, and git-commit
3711     #     6. Back in the main tree, fast forward to the new HEAD
3712
3713     # Another situation we may have to cope with is gbp-style
3714     # patches-unapplied trees.
3715     #
3716     # We would want to detect these, so we know to escape into
3717     # quilt_fixup_gbp.  However, this is in general not possible.
3718     # Consider a package with a one patch which the dgit user reverts
3719     # (with git-revert or the moral equivalent).
3720     #
3721     # That is indistinguishable in contents from a patches-unapplied
3722     # tree.  And looking at the history to distinguish them is not
3723     # useful because the user might have made a confusing-looking git
3724     # history structure (which ought to produce an error if dgit can't
3725     # cope, not a silent reintroduction of an unwanted patch).
3726     #
3727     # So gbp users will have to pass an option.  But we can usually
3728     # detect their failure to do so: if the tree is not a clean
3729     # patches-applied tree, quilt linearisation fails, but the tree
3730     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3731     # they want --quilt=unapplied.
3732     #
3733     # To help detect this, when we are extracting the fake dsc, we
3734     # first extract it with --skip-patches, and then apply the patches
3735     # afterwards with dpkg-source --before-build.  That lets us save a
3736     # tree object corresponding to .origs.
3737
3738     my $splitbrain_cachekey;
3739
3740     quilt_make_fake_dsc($upstreamversion);
3741
3742     if (quiltmode_splitbrain()) {
3743         my $cachehit;