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