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