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