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