chiark / gitweb /
.dsc and file handling: Add some debugging output
[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 changes-origs-exactly
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' => "dummycatapi:",
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 sub parse_dscdata () {
964     my $dscfh = new IO::File \$dscdata, '<' or die $!;
965     printdebug Dumper($dscdata) if $debuglevel>1;
966     $dsc = parsecontrolfh($dscfh,$dscurl,1);
967     printdebug Dumper($dsc) if $debuglevel>1;
968 }
969
970 our %rmad;
971
972 sub archive_query ($;@) {
973     my ($method) = shift @_;
974     my $query = access_cfg('archive-query','RETURN-UNDEF');
975     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
976     my $proto = $1;
977     my $data = $'; #';
978     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data,@_); }
979 }
980
981 sub pool_dsc_subpath ($$) {
982     my ($vsn,$component) = @_; # $package is implict arg
983     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
984     return "/pool/$component/$prefix/$package/".dscfn($vsn);
985 }
986
987 #---------- `ftpmasterapi' archive query method (nascent) ----------
988
989 sub archive_api_query_cmd ($) {
990     my ($subpath) = @_;
991     my @cmd = (@curl, qw(-sS));
992     my $url = access_cfg('archive-query-url');
993     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
994         my $host = $1;
995         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
996         foreach my $key (split /\:/, $keys) {
997             $key =~ s/\%HOST\%/$host/g;
998             if (!stat $key) {
999                 fail "for $url: stat $key: $!" unless $!==ENOENT;
1000                 next;
1001             }
1002             fail "config requested specific TLS key but do not know".
1003                 " how to get curl to use exactly that EE key ($key)";
1004 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
1005 #           # Sadly the above line does not work because of changes
1006 #           # to gnutls.   The real fix for #790093 may involve
1007 #           # new curl options.
1008             last;
1009         }
1010         # Fixing #790093 properly will involve providing a value
1011         # for this on clients.
1012         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
1013         push @cmd, split / /, $kargs if defined $kargs;
1014     }
1015     push @cmd, $url.$subpath;
1016     return @cmd;
1017 }
1018
1019 sub api_query ($$;$) {
1020     use JSON;
1021     my ($data, $subpath, $ok404) = @_;
1022     badcfg "ftpmasterapi archive query method takes no data part"
1023         if length $data;
1024     my @cmd = archive_api_query_cmd($subpath);
1025     my $url = $cmd[$#cmd];
1026     push @cmd, qw(-w %{http_code});
1027     my $json = cmdoutput @cmd;
1028     unless ($json =~ s/\d+\d+\d$//) {
1029         failedcmd_report_cmd undef, @cmd;
1030         fail "curl failed to print 3-digit HTTP code";
1031     }
1032     my $code = $&;
1033     return undef if $code eq '404' && $ok404;
1034     fail "fetch of $url gave HTTP code $code"
1035         unless $url =~ m#^file://# or $code =~ m/^2/;
1036     return decode_json($json);
1037 }
1038
1039 sub canonicalise_suite_ftpmasterapi {
1040     my ($proto,$data) = @_;
1041     my $suites = api_query($data, 'suites');
1042     my @matched;
1043     foreach my $entry (@$suites) {
1044         next unless grep { 
1045             my $v = $entry->{$_};
1046             defined $v && $v eq $isuite;
1047         } qw(codename name);
1048         push @matched, $entry;
1049     }
1050     fail "unknown suite $isuite" unless @matched;
1051     my $cn;
1052     eval {
1053         @matched==1 or die "multiple matches for suite $isuite\n";
1054         $cn = "$matched[0]{codename}";
1055         defined $cn or die "suite $isuite info has no codename\n";
1056         $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
1057     };
1058     die "bad ftpmaster api response: $@\n".Dumper(\@matched)
1059         if length $@;
1060     return $cn;
1061 }
1062
1063 sub archive_query_ftpmasterapi {
1064     my ($proto,$data) = @_;
1065     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
1066     my @rows;
1067     my $digester = Digest::SHA->new(256);
1068     foreach my $entry (@$info) {
1069         eval {
1070             my $vsn = "$entry->{version}";
1071             my ($ok,$msg) = version_check $vsn;
1072             die "bad version: $msg\n" unless $ok;
1073             my $component = "$entry->{component}";
1074             $component =~ m/^$component_re$/ or die "bad component";
1075             my $filename = "$entry->{filename}";
1076             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
1077                 or die "bad filename";
1078             my $sha256sum = "$entry->{sha256sum}";
1079             $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
1080             push @rows, [ $vsn, "/pool/$component/$filename",
1081                           $digester, $sha256sum ];
1082         };
1083         die "bad ftpmaster api response: $@\n".Dumper($entry)
1084             if length $@;
1085     }
1086     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1087     return @rows;
1088 }
1089
1090 sub file_in_archive_ftpmasterapi {
1091     my ($proto,$data,$filename) = @_;
1092     my $pat = $filename;
1093     $pat =~ s/_/\\_/g;
1094     $pat = "%/$pat";
1095     $pat =~ s#[^-+_.0-9a-z/]# sprintf '%%%02x', ord $& #ge;
1096     my $info = api_query($data, "file_in_archive/$pat", 1);
1097 }
1098
1099 #---------- `dummyapicat' archive query method ----------
1100
1101 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1102 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1103
1104 sub file_in_archive_dummycatapi ($$$) {
1105     my ($proto,$data,$filename) = @_;
1106     my $mirror = access_cfg('mirror');
1107     $mirror =~ s#^file://#/# or die "$mirror ?";
1108     my @out;
1109     my @cmd = (qw(sh -ec), '
1110             cd "$1"
1111             find -name "$2" -print0 |
1112             xargs -0r sha256sum
1113         ', qw(x), $mirror, $filename);
1114     debugcmd "-|", @cmd;
1115     open FIA, "-|", @cmd or die $!;
1116     while (<FIA>) {
1117         chomp or die;
1118         printdebug "| $_\n";
1119         m/^(\w+)  (\S+)$/ or die "$_ ?";
1120         push @out, { sha256sum => $1, filename => $2 };
1121     }
1122     close FIA or die failedcmd @cmd;
1123     return \@out;
1124 }
1125
1126 #---------- `madison' archive query method ----------
1127
1128 sub archive_query_madison {
1129     return map { [ @$_[0..1] ] } madison_get_parse(@_);
1130 }
1131
1132 sub madison_get_parse {
1133     my ($proto,$data) = @_;
1134     die unless $proto eq 'madison';
1135     if (!length $data) {
1136         $data= access_cfg('madison-distro','RETURN-UNDEF');
1137         $data //= access_basedistro();
1138     }
1139     $rmad{$proto,$data,$package} ||= cmdoutput
1140         qw(rmadison -asource),"-s$isuite","-u$data",$package;
1141     my $rmad = $rmad{$proto,$data,$package};
1142
1143     my @out;
1144     foreach my $l (split /\n/, $rmad) {
1145         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1146                   \s*( [^ \t|]+ )\s* \|
1147                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1148                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1149         $1 eq $package or die "$rmad $package ?";
1150         my $vsn = $2;
1151         my $newsuite = $3;
1152         my $component;
1153         if (defined $4) {
1154             $component = $4;
1155         } else {
1156             $component = access_cfg('archive-query-default-component');
1157         }
1158         $5 eq 'source' or die "$rmad ?";
1159         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1160     }
1161     return sort { -version_compare($a->[0],$b->[0]); } @out;
1162 }
1163
1164 sub canonicalise_suite_madison {
1165     # madison canonicalises for us
1166     my @r = madison_get_parse(@_);
1167     @r or fail
1168         "unable to canonicalise suite using package $package".
1169         " which does not appear to exist in suite $isuite;".
1170         " --existing-package may help";
1171     return $r[0][2];
1172 }
1173
1174 sub file_in_archive_madison { return undef; }
1175
1176 #---------- `sshpsql' archive query method ----------
1177
1178 sub sshpsql ($$$) {
1179     my ($data,$runeinfo,$sql) = @_;
1180     if (!length $data) {
1181         $data= access_someuserhost('sshpsql').':'.
1182             access_cfg('sshpsql-dbname');
1183     }
1184     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1185     my ($userhost,$dbname) = ($`,$'); #';
1186     my @rows;
1187     my @cmd = (access_cfg_ssh, $userhost,
1188                access_runeinfo("ssh-psql $runeinfo").
1189                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1190                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1191     debugcmd "|",@cmd;
1192     open P, "-|", @cmd or die $!;
1193     while (<P>) {
1194         chomp or die;
1195         printdebug(">|$_|\n");
1196         push @rows, $_;
1197     }
1198     $!=0; $?=0; close P or failedcmd @cmd;
1199     @rows or die;
1200     my $nrows = pop @rows;
1201     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1202     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1203     @rows = map { [ split /\|/, $_ ] } @rows;
1204     my $ncols = scalar @{ shift @rows };
1205     die if grep { scalar @$_ != $ncols } @rows;
1206     return @rows;
1207 }
1208
1209 sub sql_injection_check {
1210     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1211 }
1212
1213 sub archive_query_sshpsql ($$) {
1214     my ($proto,$data) = @_;
1215     sql_injection_check $isuite, $package;
1216     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1217         SELECT source.version, component.name, files.filename, files.sha256sum
1218           FROM source
1219           JOIN src_associations ON source.id = src_associations.source
1220           JOIN suite ON suite.id = src_associations.suite
1221           JOIN dsc_files ON dsc_files.source = source.id
1222           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1223           JOIN component ON component.id = files_archive_map.component_id
1224           JOIN files ON files.id = dsc_files.file
1225          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1226            AND source.source='$package'
1227            AND files.filename LIKE '%.dsc';
1228 END
1229     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1230     my $digester = Digest::SHA->new(256);
1231     @rows = map {
1232         my ($vsn,$component,$filename,$sha256sum) = @$_;
1233         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1234     } @rows;
1235     return @rows;
1236 }
1237
1238 sub canonicalise_suite_sshpsql ($$) {
1239     my ($proto,$data) = @_;
1240     sql_injection_check $isuite;
1241     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1242         SELECT suite.codename
1243           FROM suite where suite_name='$isuite' or codename='$isuite';
1244 END
1245     @rows = map { $_->[0] } @rows;
1246     fail "unknown suite $isuite" unless @rows;
1247     die "ambiguous $isuite: @rows ?" if @rows>1;
1248     return $rows[0];
1249 }
1250
1251 sub file_in_archive_sshpsql ($$$) { return undef; }
1252
1253 #---------- `dummycat' archive query method ----------
1254
1255 sub canonicalise_suite_dummycat ($$) {
1256     my ($proto,$data) = @_;
1257     my $dpath = "$data/suite.$isuite";
1258     if (!open C, "<", $dpath) {
1259         $!==ENOENT or die "$dpath: $!";
1260         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1261         return $isuite;
1262     }
1263     $!=0; $_ = <C>;
1264     chomp or die "$dpath: $!";
1265     close C;
1266     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1267     return $_;
1268 }
1269
1270 sub archive_query_dummycat ($$) {
1271     my ($proto,$data) = @_;
1272     canonicalise_suite();
1273     my $dpath = "$data/package.$csuite.$package";
1274     if (!open C, "<", $dpath) {
1275         $!==ENOENT or die "$dpath: $!";
1276         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1277         return ();
1278     }
1279     my @rows;
1280     while (<C>) {
1281         next if m/^\#/;
1282         next unless m/\S/;
1283         die unless chomp;
1284         printdebug "dummycat query $csuite $package $dpath | $_\n";
1285         my @row = split /\s+/, $_;
1286         @row==2 or die "$dpath: $_ ?";
1287         push @rows, \@row;
1288     }
1289     C->error and die "$dpath: $!";
1290     close C;
1291     return sort { -version_compare($a->[0],$b->[0]); } @rows;
1292 }
1293
1294 sub file_in_archive_dummycat () { return undef; }
1295
1296 #---------- tag format handling ----------
1297
1298 sub access_cfg_tagformats () {
1299     split /\,/, access_cfg('dgit-tag-format');
1300 }
1301
1302 sub need_tagformat ($$) {
1303     my ($fmt, $why) = @_;
1304     fail "need to use tag format $fmt ($why) but also need".
1305         " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1306         " - no way to proceed"
1307         if $tagformat_want && $tagformat_want->[0] ne $fmt;
1308     $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1309 }
1310
1311 sub select_tagformat () {
1312     # sets $tagformatfn
1313     return if $tagformatfn && !$tagformat_want;
1314     die 'bug' if $tagformatfn && $tagformat_want;
1315     # ... $tagformat_want assigned after previous select_tagformat
1316
1317     my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1318     printdebug "select_tagformat supported @supported\n";
1319
1320     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1321     printdebug "select_tagformat specified @$tagformat_want\n";
1322
1323     my ($fmt,$why,$override) = @$tagformat_want;
1324
1325     fail "target distro supports tag formats @supported".
1326         " but have to use $fmt ($why)"
1327         unless $override
1328             or grep { $_ eq $fmt } @supported;
1329
1330     $tagformat_want = undef;
1331     $tagformat = $fmt;
1332     $tagformatfn = ${*::}{"debiantag_$fmt"};
1333
1334     fail "trying to use unknown tag format \`$fmt' ($why) !"
1335         unless $tagformatfn;
1336 }
1337
1338 #---------- archive query entrypoints and rest of program ----------
1339
1340 sub canonicalise_suite () {
1341     return if defined $csuite;
1342     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1343     $csuite = archive_query('canonicalise_suite');
1344     if ($isuite ne $csuite) {
1345         progress "canonical suite name for $isuite is $csuite";
1346     }
1347 }
1348
1349 sub get_archive_dsc () {
1350     canonicalise_suite();
1351     my @vsns = archive_query('archive_query');
1352     foreach my $vinfo (@vsns) {
1353         my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1354         $dscurl = access_cfg('mirror').$subpath;
1355         $dscdata = url_get($dscurl);
1356         if (!$dscdata) {
1357             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1358             next;
1359         }
1360         if ($digester) {
1361             $digester->reset();
1362             $digester->add($dscdata);
1363             my $got = $digester->hexdigest();
1364             $got eq $digest or
1365                 fail "$dscurl has hash $got but".
1366                     " archive told us to expect $digest";
1367         }
1368         parse_dscdata();
1369         my $fmt = getfield $dsc, 'Format';
1370         $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1371             "unsupported source format $fmt, sorry";
1372             
1373         $dsc_checked = !!$digester;
1374         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1375         return;
1376     }
1377     $dsc = undef;
1378     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1379 }
1380
1381 sub check_for_git ();
1382 sub check_for_git () {
1383     # returns 0 or 1
1384     my $how = access_cfg('git-check');
1385     if ($how eq 'ssh-cmd') {
1386         my @cmd =
1387             (access_cfg_ssh, access_gituserhost(),
1388              access_runeinfo("git-check $package").
1389              " set -e; cd ".access_cfg('git-path').";".
1390              " if test -d $package.git; then echo 1; else echo 0; fi");
1391         my $r= cmdoutput @cmd;
1392         if (defined $r and $r =~ m/^divert (\w+)$/) {
1393             my $divert=$1;
1394             my ($usedistro,) = access_distros();
1395             # NB that if we are pushing, $usedistro will be $distro/push
1396             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1397             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1398             progress "diverting to $divert (using config for $instead_distro)";
1399             return check_for_git();
1400         }
1401         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1402         return $r+0;
1403     } elsif ($how eq 'url') {
1404         my $prefix = access_cfg('git-check-url','git-url');
1405         my $suffix = access_cfg('git-check-suffix','git-suffix',
1406                                 'RETURN-UNDEF') // '.git';
1407         my $url = "$prefix/$package$suffix";
1408         my @cmd = (@curl, qw(-sS -I), $url);
1409         my $result = cmdoutput @cmd;
1410         $result =~ s/^\S+ 200 .*\n\r?\n//;
1411         # curl -sS -I with https_proxy prints
1412         # HTTP/1.0 200 Connection established
1413         $result =~ m/^\S+ (404|200) /s or
1414             fail "unexpected results from git check query - ".
1415                 Dumper($prefix, $result);
1416         my $code = $1;
1417         if ($code eq '404') {
1418             return 0;
1419         } elsif ($code eq '200') {
1420             return 1;
1421         } else {
1422             die;
1423         }
1424     } elsif ($how eq 'true') {
1425         return 1;
1426     } elsif ($how eq 'false') {
1427         return 0;
1428     } else {
1429         badcfg "unknown git-check \`$how'";
1430     }
1431 }
1432
1433 sub create_remote_git_repo () {
1434     my $how = access_cfg('git-create');
1435     if ($how eq 'ssh-cmd') {
1436         runcmd_ordryrun
1437             (access_cfg_ssh, access_gituserhost(),
1438              access_runeinfo("git-create $package").
1439              "set -e; cd ".access_cfg('git-path').";".
1440              " cp -a _template $package.git");
1441     } elsif ($how eq 'true') {
1442         # nothing to do
1443     } else {
1444         badcfg "unknown git-create \`$how'";
1445     }
1446 }
1447
1448 our ($dsc_hash,$lastpush_mergeinput);
1449
1450 our $ud = '.git/dgit/unpack';
1451
1452 sub prep_ud (;$) {
1453     my ($d) = @_;
1454     $d //= $ud;
1455     rmtree($d);
1456     mkpath '.git/dgit';
1457     mkdir $d or die $!;
1458 }
1459
1460 sub mktree_in_ud_here () {
1461     runcmd qw(git init -q);
1462     runcmd qw(git config gc.auto 0);
1463     rmtree('.git/objects');
1464     symlink '../../../../objects','.git/objects' or die $!;
1465 }
1466
1467 sub git_write_tree () {
1468     my $tree = cmdoutput @git, qw(write-tree);
1469     $tree =~ m/^\w+$/ or die "$tree ?";
1470     return $tree;
1471 }
1472
1473 sub remove_stray_gits () {
1474     my @gitscmd = qw(find -name .git -prune -print0);
1475     debugcmd "|",@gitscmd;
1476     open GITS, "-|", @gitscmd or die $!;
1477     {
1478         local $/="\0";
1479         while (<GITS>) {
1480             chomp or die;
1481             print STDERR "$us: warning: removing from source package: ",
1482                 (messagequote $_), "\n";
1483             rmtree $_;
1484         }
1485     }
1486     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1487 }
1488
1489 sub mktree_in_ud_from_only_subdir (;$) {
1490     my ($raw) = @_;
1491
1492     # changes into the subdir
1493     my (@dirs) = <*/.>;
1494     die "expected one subdir but found @dirs ?" unless @dirs==1;
1495     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1496     my $dir = $1;
1497     changedir $dir;
1498
1499     remove_stray_gits();
1500     mktree_in_ud_here();
1501     if (!$raw) {
1502         my ($format, $fopts) = get_source_format();
1503         if (madformat($format)) {
1504             rmtree '.pc';
1505         }
1506     }
1507
1508     runcmd @git, qw(add -Af);
1509     my $tree=git_write_tree();
1510     return ($tree,$dir);
1511 }
1512
1513 our @files_csum_info_fields = 
1514     (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1515      ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
1516      ['Files',           'Digest::MD5', 'new()',    'md5sum']);
1517
1518 sub dsc_files_info () {
1519     foreach my $csumi (@files_csum_info_fields) {
1520         my ($fname, $module, $method) = @$csumi;
1521         my $field = $dsc->{$fname};
1522         next unless defined $field;
1523         eval "use $module; 1;" or die $@;
1524         my @out;
1525         foreach (split /\n/, $field) {
1526             next unless m/\S/;
1527             m/^(\w+) (\d+) (\S+)$/ or
1528                 fail "could not parse .dsc $fname line \`$_'";
1529             my $digester = eval "$module"."->$method;" or die $@;
1530             push @out, {
1531                 Hash => $1,
1532                 Bytes => $2,
1533                 Filename => $3,
1534                 Digester => $digester,
1535             };
1536         }
1537         return @out;
1538     }
1539     fail "missing any supported Checksums-* or Files field in ".
1540         $dsc->get_option('name');
1541 }
1542
1543 sub dsc_files () {
1544     map { $_->{Filename} } dsc_files_info();
1545 }
1546
1547 sub files_compare_inputs (@) {
1548     my $inputs = \@_;
1549     my %record;
1550     my %fchecked;
1551
1552     my $showinputs = sub {
1553         return join "; ", map { $_->get_option('name') } @$inputs;
1554     };
1555
1556     foreach my $in (@$inputs) {
1557         my $expected_files;
1558         my $in_name = $in->get_option('name');
1559
1560         printdebug "files_compare_inputs $in_name\n";
1561
1562         foreach my $csumi (@files_csum_info_fields) {
1563             my ($fname) = @$csumi;
1564             printdebug "files_compare_inputs $in_name $fname\n";
1565
1566             my $field = $in->{$fname};
1567             next unless defined $field;
1568
1569             my @files;
1570             foreach (split /\n/, $field) {
1571                 next unless m/\S/;
1572
1573                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1574                     fail "could not parse $in_name $fname line \`$_'";
1575
1576                 printdebug "files_compare_inputs $in_name $fname $f\n";
1577
1578                 push @files, $f;
1579
1580                 my $re = \ $record{$f}{$fname};
1581                 if (defined $$re) {
1582                     $fchecked{$f}{$in_name} = 1;
1583                     $$re eq $info or
1584                         fail "hash or size of $f varies in $fname fields".
1585                         " (between: ".$showinputs->().")";
1586                 } else {
1587                     $$re = $info;
1588                 }
1589             }
1590             @files = sort @files;
1591             $expected_files //= \@files;
1592             "@$expected_files" eq "@files" or
1593                 fail "file list in $in_name varies between hash fields!";
1594         }
1595         $expected_files or
1596             fail "$in_name has no files list field(s)";
1597     }
1598     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1599         if $debuglevel>=2;
1600
1601     grep { keys %$_ == @$inputs-1 } values %fchecked
1602         or fail "no file appears in all file lists".
1603         " (looked in: ".$showinputs->().")";
1604 }
1605
1606 sub is_orig_file_in_dsc ($$) {
1607     my ($f, $dsc_files_info) = @_;
1608     return 0 if @$dsc_files_info <= 1;
1609     # One file means no origs, and the filename doesn't have a "what
1610     # part of dsc" component.  (Consider versions ending `.orig'.)
1611     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1612     return 1;
1613 }
1614
1615 sub is_orig_file_of_vsn ($$) {
1616     my ($f, $upstreamvsn) = @_;
1617     my $base = srcfn $upstreamvsn, '';
1618     return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1619     return 1;
1620 }
1621
1622 sub changes_update_origs_from_dsc ($$$$) {
1623     my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1624     my %changes_f;
1625     printdebug "checking origs needed ($upstreamvsn)...\n";
1626     $_ = getfield $changes, 'Files';
1627     m/^\w+ \d+ (\S+ \S+) \S+$/m or
1628         fail "cannot find section/priority from .changes Files field";
1629     my $placementinfo = $1;
1630     my %changed;
1631     printdebug "checking origs needed placement '$placementinfo'...\n";
1632     foreach my $l (split /\n/, getfield $dsc, 'Files') {
1633         $l =~ m/\S+$/ or next;
1634         my $file = $&;
1635         printdebug "origs $file | $l\n";
1636         next unless is_orig_file_of_vsn $file, $upstreamvsn;
1637         printdebug "origs $file is_orig\n";
1638         my $have = archive_query('file_in_archive', $file);
1639         if (!defined $have) {
1640             print STDERR <<END;
1641 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1642 END
1643             return;
1644         }
1645         my $found_same = 0;
1646         my @found_differ;
1647         printdebug "origs $file \$#\$have=$#$have\n";
1648         foreach my $h (@$have) {
1649             my $same = 0;
1650             my @differ;
1651             foreach my $csumi (@files_csum_info_fields) {
1652                 my ($fname, $module, $method, $archivefield) = @$csumi;
1653                 next unless defined $h->{$archivefield};
1654                 $_ = $dsc->{$fname};
1655                 next unless defined;
1656                 m/^(\w+) .* \Q$file\E$/m or
1657                     fail ".dsc $fname missing entry for $file";
1658                 if ($h->{$archivefield} eq $1) {
1659                     $same++;
1660                 } else {
1661                     push @differ,
1662  "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1663                 }
1664             }
1665             die "$file ".Dumper($h)." ?!" if $same && @differ;
1666             $found_same++
1667                 if $same;
1668             push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1669                 if @differ;
1670         }
1671         print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1672         if (@found_differ && !$found_same) {
1673             fail join "\n",
1674                 "archive contains $file with different checksum",
1675                 @found_differ;
1676         }
1677         # Now we edit the changes file to add or remove it
1678         foreach my $csumi (@files_csum_info_fields) {
1679             my ($fname, $module, $method, $archivefield) = @$csumi;
1680             next unless defined $changes->{$fname};
1681             if ($found_same) {
1682                 # in archive, delete from .changes if it's there
1683                 $changed{$file} = "removed" if
1684                     $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1685             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1686                 # not in archive, but it's here in the .changes
1687             } else {
1688                 my $dsc_data = getfield $dsc, $fname;
1689                 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1690                 my $extra = $1;
1691                 $extra =~ s/ \d+ /$&$placementinfo /
1692                     or die "$fname $extra >$dsc_data< ?"
1693                     if $fname eq 'Files';
1694                 $changes->{$fname} .= "\n". $extra;
1695                 $changed{$file} = "added";
1696             }
1697         }
1698     }
1699     if (%changed) {
1700         foreach my $file (keys %changed) {
1701             progress sprintf
1702                 "edited .changes for archive .orig contents: %s %s",
1703                 $changed{$file}, $file;
1704         }
1705         my $chtmp = "$changesfile.tmp";
1706         $changes->save($chtmp);
1707         if (act_local()) {
1708             rename $chtmp,$changesfile or die "$changesfile $!";
1709         } else {
1710             progress "[new .changes left in $changesfile]";
1711         }
1712     } else {
1713         progress "$changesfile already has appropriate .orig(s) (if any)";
1714     }
1715 }
1716
1717 sub make_commit ($) {
1718     my ($file) = @_;
1719     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1720 }
1721
1722 sub make_commit_text ($) {
1723     my ($text) = @_;
1724     my ($out, $in);
1725     my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1726     debugcmd "|",@cmd;
1727     print Dumper($text) if $debuglevel > 1;
1728     my $child = open2($out, $in, @cmd) or die $!;
1729     my $h;
1730     eval {
1731         print $in $text or die $!;
1732         close $in or die $!;
1733         $h = <$out>;
1734         $h =~ m/^\w+$/ or die;
1735         $h = $&;
1736         printdebug "=> $h\n";
1737     };
1738     close $out;
1739     waitpid $child, 0 == $child or die "$child $!";
1740     $? and failedcmd @cmd;
1741     return $h;
1742 }
1743
1744 sub clogp_authline ($) {
1745     my ($clogp) = @_;
1746     my $author = getfield $clogp, 'Maintainer';
1747     $author =~ s#,.*##ms;
1748     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1749     my $authline = "$author $date";
1750     $authline =~ m/$git_authline_re/o or
1751         fail "unexpected commit author line format \`$authline'".
1752         " (was generated from changelog Maintainer field)";
1753     return ($1,$2,$3) if wantarray;
1754     return $authline;
1755 }
1756
1757 sub vendor_patches_distro ($$) {
1758     my ($checkdistro, $what) = @_;
1759     return unless defined $checkdistro;
1760
1761     my $series = "debian/patches/\L$checkdistro\E.series";
1762     printdebug "checking for vendor-specific $series ($what)\n";
1763
1764     if (!open SERIES, "<", $series) {
1765         die "$series $!" unless $!==ENOENT;
1766         return;
1767     }
1768     while (<SERIES>) {
1769         next unless m/\S/;
1770         next if m/^\s+\#/;
1771
1772         print STDERR <<END;
1773
1774 Unfortunately, this source package uses a feature of dpkg-source where
1775 the same source package unpacks to different source code on different
1776 distros.  dgit cannot safely operate on such packages on affected
1777 distros, because the meaning of source packages is not stable.
1778
1779 Please ask the distro/maintainer to remove the distro-specific series
1780 files and use a different technique (if necessary, uploading actually
1781 different packages, if different distros are supposed to have
1782 different code).
1783
1784 END
1785         fail "Found active distro-specific series file for".
1786             " $checkdistro ($what): $series, cannot continue";
1787     }
1788     die "$series $!" if SERIES->error;
1789     close SERIES;
1790 }
1791
1792 sub check_for_vendor_patches () {
1793     # This dpkg-source feature doesn't seem to be documented anywhere!
1794     # But it can be found in the changelog (reformatted):
1795
1796     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1797     #   Author: Raphael Hertzog <hertzog@debian.org>
1798     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1799
1800     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1801     #   series files
1802     #   
1803     #   If you have debian/patches/ubuntu.series and you were
1804     #   unpacking the source package on ubuntu, quilt was still
1805     #   directed to debian/patches/series instead of
1806     #   debian/patches/ubuntu.series.
1807     #   
1808     #   debian/changelog                        |    3 +++
1809     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1810     #   2 files changed, 6 insertions(+), 1 deletion(-)
1811
1812     use Dpkg::Vendor;
1813     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1814     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1815                          "Dpkg::Vendor \`current vendor'");
1816     vendor_patches_distro(access_basedistro(),
1817                           "distro being accessed");
1818 }
1819
1820 sub generate_commits_from_dsc () {
1821     # See big comment in fetch_from_archive, below.
1822     # See also README.dsc-import.
1823     prep_ud();
1824     changedir $ud;
1825
1826     my @dfi = dsc_files_info();
1827     foreach my $fi (@dfi) {
1828         my $f = $fi->{Filename};
1829         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1830
1831         printdebug "considering linking $f: ";
1832
1833         link_ltarget "../../../$f", $f
1834             or ((printdebug "($!) "), 0)
1835             or $!==&ENOENT
1836             or die "$f $!";
1837
1838         printdebug "linked.\n";
1839
1840         complete_file_from_dsc('.', $fi)
1841             or next;
1842
1843         if (is_orig_file_in_dsc($f, \@dfi)) {
1844             link $f, "../../../../$f"
1845                 or $!==&EEXIST
1846                 or die "$f $!";
1847         }
1848     }
1849
1850     # We unpack and record the orig tarballs first, so that we only
1851     # need disk space for one private copy of the unpacked source.
1852     # But we can't make them into commits until we have the metadata
1853     # from the debian/changelog, so we record the tree objects now and
1854     # make them into commits later.
1855     my @tartrees;
1856     my $upstreamv = $dsc->{version};
1857     $upstreamv =~ s/-[^-]+$//;
1858     my $orig_f_base = srcfn $upstreamv, '';
1859
1860     foreach my $fi (@dfi) {
1861         # We actually import, and record as a commit, every tarball
1862         # (unless there is only one file, in which case there seems
1863         # little point.
1864
1865         my $f = $fi->{Filename};
1866         printdebug "import considering $f ";
1867         (printdebug "only one dfi\n"), next if @dfi == 1;
1868         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
1869         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
1870         my $compr_ext = $1;
1871
1872         my ($orig_f_part) =
1873             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
1874
1875         printdebug "Y ", (join ' ', map { $_//"(none)" }
1876                           $compr_ext, $orig_f_part
1877                          ), "\n";
1878
1879         my $input = new IO::File $f, '<' or die "$f $!";
1880         my $compr_pid;
1881         my @compr_cmd;
1882
1883         if (defined $compr_ext) {
1884             my $cname =
1885                 Dpkg::Compression::compression_guess_from_filename $f;
1886             fail "Dpkg::Compression cannot handle file $f in source package"
1887                 if defined $compr_ext && !defined $cname;
1888             my $compr_proc =
1889                 new Dpkg::Compression::Process compression => $cname;
1890             my @compr_cmd = $compr_proc->get_uncompress_cmdline();
1891             my $compr_fh = new IO::Handle;
1892             my $compr_pid = open $compr_fh, "-|" // die $!;
1893             if (!$compr_pid) {
1894                 open STDIN, "<&", $input or die $!;
1895                 exec @compr_cmd;
1896                 die "dgit (child): exec $compr_cmd[0]: $!\n";
1897             }
1898             $input = $compr_fh;
1899         }
1900
1901         rmtree "../unpack-tar";
1902         mkdir "../unpack-tar" or die $!;
1903         my @tarcmd = qw(tar -x -f -
1904                         --no-same-owner --no-same-permissions
1905                         --no-acls --no-xattrs --no-selinux);
1906         my $tar_pid = fork // die $!;
1907         if (!$tar_pid) {
1908             chdir "../unpack-tar" or die $!;
1909             open STDIN, "<&", $input or die $!;
1910             exec @tarcmd;
1911             die "dgit (child): exec $tarcmd[0]: $!";
1912         }
1913         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
1914         !$? or failedcmd @tarcmd;
1915
1916         close $input or
1917             (@compr_cmd ? failedcmd @compr_cmd
1918              : die $!);
1919         # finally, we have the results in "tarball", but maybe
1920         # with the wrong permissions
1921
1922         runcmd qw(chmod -R +rwX ../unpack-tar);
1923         changedir "../unpack-tar";
1924         my ($tree) = mktree_in_ud_from_only_subdir(1);
1925         changedir "../../unpack";
1926         rmtree "../unpack-tar";
1927
1928         my $ent = [ $f, $tree ];
1929         push @tartrees, {
1930             Orig => !!$orig_f_part,
1931             Sort => (!$orig_f_part         ? 2 :
1932                      $orig_f_part =~ m/-/g ? 1 :
1933                                              0),
1934             F => $f,
1935             Tree => $tree,
1936         };
1937     }
1938
1939     @tartrees = sort {
1940         # put any without "_" first (spec is not clear whether files
1941         # are always in the usual order).  Tarballs without "_" are
1942         # the main orig or the debian tarball.
1943         $a->{Sort} <=> $b->{Sort} or
1944         $a->{F}    cmp $b->{F}
1945     } @tartrees;
1946
1947     my $any_orig = grep { $_->{Orig} } @tartrees;
1948
1949     my $dscfn = "$package.dsc";
1950
1951     my $treeimporthow = 'package';
1952
1953     open D, ">", $dscfn or die "$dscfn: $!";
1954     print D $dscdata or die "$dscfn: $!";
1955     close D or die "$dscfn: $!";
1956     my @cmd = qw(dpkg-source);
1957     push @cmd, '--no-check' if $dsc_checked;
1958     if (madformat $dsc->{format}) {
1959         push @cmd, '--skip-patches';
1960         $treeimporthow = 'unpatched';
1961     }
1962     push @cmd, qw(-x --), $dscfn;
1963     runcmd @cmd;
1964
1965     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1966     if (madformat $dsc->{format}) { 
1967         check_for_vendor_patches();
1968     }
1969
1970     my $dappliedtree;
1971     if (madformat $dsc->{format}) {
1972         my @pcmd = qw(dpkg-source --before-build .);
1973         runcmd shell_cmd 'exec >/dev/null', @pcmd;
1974         rmtree '.pc';
1975         runcmd @git, qw(add -Af);
1976         $dappliedtree = git_write_tree();
1977     }
1978
1979     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
1980     debugcmd "|",@clogcmd;
1981     open CLOGS, "-|", @clogcmd or die $!;
1982
1983     my $clogp;
1984     my $r1clogp;
1985
1986     printdebug "import clog search...\n";
1987
1988     for (;;) {
1989         my $stanzatext = do { local $/=""; <CLOGS>; };
1990         printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
1991         last if !defined $stanzatext;
1992
1993         my $desc = "package changelog, entry no.$.";
1994         open my $stanzafh, "<", \$stanzatext or die;
1995         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
1996         $clogp //= $thisstanza;
1997
1998         printdebug "import clog $thisstanza->{version} $desc...\n";
1999
2000         last if !$any_orig; # we don't need $r1clogp
2001
2002         # We look for the first (most recent) changelog entry whose
2003         # version number is lower than the upstream version of this
2004         # package.  Then the last (least recent) previous changelog
2005         # entry is treated as the one which introduced this upstream
2006         # version and used for the synthetic commits for the upstream
2007         # tarballs.
2008
2009         # One might think that a more sophisticated algorithm would be
2010         # necessary.  But: we do not want to scan the whole changelog
2011         # file.  Stopping when we see an earlier version, which
2012         # necessarily then is an earlier upstream version, is the only
2013         # realistic way to do that.  Then, either the earliest
2014         # changelog entry we have seen so far is indeed the earliest
2015         # upload of this upstream version; or there are only changelog
2016         # entries relating to later upstream versions (which is not
2017         # possible unless the changelog and .dsc disagree about the
2018         # version).  Then it remains to choose between the physically
2019         # last entry in the file, and the one with the lowest version
2020         # number.  If these are not the same, we guess that the
2021         # versions were created in a non-monotic order rather than
2022         # that the changelog entries have been misordered.
2023
2024         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2025
2026         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2027         $r1clogp = $thisstanza;
2028
2029         printdebug "import clog $r1clogp->{version} becomes r1\n";
2030     }
2031     die $! if CLOGS->error;
2032     close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2033
2034     $clogp or fail "package changelog has no entries!";
2035
2036     my $authline = clogp_authline $clogp;
2037     my $changes = getfield $clogp, 'Changes';
2038     my $cversion = getfield $clogp, 'Version';
2039
2040     if (@tartrees) {
2041         $r1clogp //= $clogp; # maybe there's only one entry;
2042         my $r1authline = clogp_authline $r1clogp;
2043         # Strictly, r1authline might now be wrong if it's going to be
2044         # unused because !$any_orig.  Whatever.
2045
2046         printdebug "import tartrees authline   $authline\n";
2047         printdebug "import tartrees r1authline $r1authline\n";
2048
2049         foreach my $tt (@tartrees) {
2050             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2051
2052             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2053 tree $tt->{Tree}
2054 author $r1authline
2055 committer $r1authline
2056
2057 Import $tt->{F}
2058
2059 [dgit import orig $tt->{F}]
2060 END_O
2061 tree $tt->{Tree}
2062 author $authline
2063 committer $authline
2064
2065 Import $tt->{F}
2066
2067 [dgit import tarball $package $cversion $tt->{F}]
2068 END_T
2069         }
2070     }
2071
2072     printdebug "import main commit\n";
2073
2074     open C, ">../commit.tmp" or die $!;
2075     print C <<END or die $!;
2076 tree $tree
2077 END
2078     print C <<END or die $! foreach @tartrees;
2079 parent $_->{Commit}
2080 END
2081     print C <<END or die $!;
2082 author $authline
2083 committer $authline
2084
2085 $changes
2086
2087 [dgit import $treeimporthow $package $cversion]
2088 END
2089
2090     close C or die $!;
2091     my $rawimport_hash = make_commit qw(../commit.tmp);
2092
2093     if (madformat $dsc->{format}) {
2094         printdebug "import apply patches...\n";
2095
2096         # regularise the state of the working tree so that
2097         # the checkout of $rawimport_hash works nicely.
2098         my $dappliedcommit = make_commit_text(<<END);
2099 tree $dappliedtree
2100 author $authline
2101 committer $authline
2102
2103 [dgit dummy commit]
2104 END
2105         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2106
2107         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2108
2109         # We need the answers to be reproducible
2110         my @authline = clogp_authline($clogp);
2111         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2112         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2113         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2114         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2115         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2116         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2117
2118         my $path = $ENV{PATH} or die;
2119
2120         foreach my $use_absurd (qw(0 1)) {
2121             local $ENV{PATH} = $path;
2122             if ($use_absurd) {
2123                 chomp $@;
2124                 progress "warning: $@";
2125                 $path = "$absurdity:$path";
2126                 progress "$us: trying slow absurd-git-apply...";
2127                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2128                     or $!==ENOENT
2129                     or die $!;
2130             }
2131             eval {
2132                 die "forbid absurd git-apply\n" if $use_absurd
2133                     && forceing [qw(import-gitapply-no-absurd)];
2134                 die "only absurd git-apply!\n" if !$use_absurd
2135                     && forceing [qw(import-gitapply-absurd)];
2136
2137                 local $ENV{PATH} = $path if $use_absurd;
2138
2139                 my @showcmd = (gbp_pq, qw(import));
2140                 my @realcmd = shell_cmd
2141                     'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2142                 debugcmd "+",@realcmd;
2143                 if (system @realcmd) {
2144                     die +(shellquote @showcmd).
2145                         " failed: ".
2146                         failedcmd_waitstatus()."\n";
2147                 }
2148
2149                 my $gapplied = git_rev_parse('HEAD');
2150                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2151                 $gappliedtree eq $dappliedtree or
2152                     fail <<END;
2153 gbp-pq import and dpkg-source disagree!
2154  gbp-pq import gave commit $gapplied
2155  gbp-pq import gave tree $gappliedtree
2156  dpkg-source --before-build gave tree $dappliedtree
2157 END
2158                 $rawimport_hash = $gapplied;
2159             };
2160             last unless $@;
2161         }
2162         if ($@) {
2163             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2164             die $@;
2165         }
2166     }
2167
2168     progress "synthesised git commit from .dsc $cversion";
2169
2170     my $rawimport_mergeinput = {
2171         Commit => $rawimport_hash,
2172         Info => "Import of source package",
2173     };
2174     my @output = ($rawimport_mergeinput);
2175
2176     if ($lastpush_mergeinput) {
2177         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2178         my $oversion = getfield $oldclogp, 'Version';
2179         my $vcmp =
2180             version_compare($oversion, $cversion);
2181         if ($vcmp < 0) {
2182             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2183                 { Message => <<END, ReverseParents => 1 });
2184 Record $package ($cversion) in archive suite $csuite
2185 END
2186         } elsif ($vcmp > 0) {
2187             print STDERR <<END or die $!;
2188
2189 Version actually in archive:   $cversion (older)
2190 Last version pushed with dgit: $oversion (newer or same)
2191 $later_warning_msg
2192 END
2193             @output = $lastpush_mergeinput;
2194         } else {
2195             # Same version.  Use what's in the server git branch,
2196             # discarding our own import.  (This could happen if the
2197             # server automatically imports all packages into git.)
2198             @output = $lastpush_mergeinput;
2199         }
2200     }
2201     changedir '../../../..';
2202     rmtree($ud);
2203     return @output;
2204 }
2205
2206 sub complete_file_from_dsc ($$) {
2207     our ($dstdir, $fi) = @_;
2208     # Ensures that we have, in $dir, the file $fi, with the correct
2209     # contents.  (Downloading it from alongside $dscurl if necessary.)
2210
2211     my $f = $fi->{Filename};
2212     my $tf = "$dstdir/$f";
2213     my $downloaded = 0;
2214
2215     if (stat_exists $tf) {
2216         progress "using existing $f";
2217     } else {
2218         printdebug "$tf does not exist, need to fetch\n";
2219         my $furl = $dscurl;
2220         $furl =~ s{/[^/]+$}{};
2221         $furl .= "/$f";
2222         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2223         die "$f ?" if $f =~ m#/#;
2224         runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2225         return 0 if !act_local();
2226         $downloaded = 1;
2227     }
2228
2229     open F, "<", "$tf" or die "$tf: $!";
2230     $fi->{Digester}->reset();
2231     $fi->{Digester}->addfile(*F);
2232     F->error and die $!;
2233     my $got = $fi->{Digester}->hexdigest();
2234     $got eq $fi->{Hash} or
2235         fail "file $f has hash $got but .dsc".
2236             " demands hash $fi->{Hash} ".
2237             ($downloaded ? "(got wrong file from archive!)"
2238              : "(perhaps you should delete this file?)");
2239
2240     return 1;
2241 }
2242
2243 sub ensure_we_have_orig () {
2244     my @dfi = dsc_files_info();
2245     foreach my $fi (@dfi) {
2246         my $f = $fi->{Filename};
2247         next unless is_orig_file_in_dsc($f, \@dfi);
2248         complete_file_from_dsc('..', $fi)
2249             or next;
2250     }
2251 }
2252
2253 sub git_fetch_us () {
2254     # Want to fetch only what we are going to use, unless
2255     # deliberately-not-ff, in which case we must fetch everything.
2256
2257     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2258         map { "tags/$_" }
2259         (quiltmode_splitbrain
2260          ? (map { $_->('*',access_basedistro) }
2261             \&debiantag_new, \&debiantag_maintview)
2262          : debiantags('*',access_basedistro));
2263     push @specs, server_branch($csuite);
2264     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2265
2266     # This is rather miserable:
2267     # When git fetch --prune is passed a fetchspec ending with a *,
2268     # it does a plausible thing.  If there is no * then:
2269     # - it matches subpaths too, even if the supplied refspec
2270     #   starts refs, and behaves completely madly if the source
2271     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2272     # - if there is no matching remote ref, it bombs out the whole
2273     #   fetch.
2274     # We want to fetch a fixed ref, and we don't know in advance
2275     # if it exists, so this is not suitable.
2276     #
2277     # Our workaround is to use git ls-remote.  git ls-remote has its
2278     # own qairks.  Notably, it has the absurd multi-tail-matching
2279     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2280     # refs/refs/foo etc.
2281     #
2282     # Also, we want an idempotent snapshot, but we have to make two
2283     # calls to the remote: one to git ls-remote and to git fetch.  The
2284     # solution is use git ls-remote to obtain a target state, and
2285     # git fetch to try to generate it.  If we don't manage to generate
2286     # the target state, we try again.
2287
2288     my $specre = join '|', map {
2289         my $x = $_;
2290         $x =~ s/\W/\\$&/g;
2291         $x =~ s/\\\*$/.*/;
2292         "(?:refs/$x)";
2293     } @specs;
2294     printdebug "git_fetch_us specre=$specre\n";
2295     my $wanted_rref = sub {
2296         local ($_) = @_;
2297         return m/^(?:$specre)$/o;
2298     };
2299
2300     my $fetch_iteration = 0;
2301     FETCH_ITERATION:
2302     for (;;) {
2303         if (++$fetch_iteration > 10) {
2304             fail "too many iterations trying to get sane fetch!";
2305         }
2306
2307         my @look = map { "refs/$_" } @specs;
2308         my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2309         debugcmd "|",@lcmd;
2310
2311         my %wantr;
2312         open GITLS, "-|", @lcmd or die $!;
2313         while (<GITLS>) {
2314             printdebug "=> ", $_;
2315             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2316             my ($objid,$rrefname) = ($1,$2);
2317             if (!$wanted_rref->($rrefname)) {
2318                 print STDERR <<END;
2319 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2320 END
2321                 next;
2322             }
2323             $wantr{$rrefname} = $objid;
2324         }
2325         $!=0; $?=0;
2326         close GITLS or failedcmd @lcmd;
2327
2328         # OK, now %want is exactly what we want for refs in @specs
2329         my @fspecs = map {
2330             return () if !m/\*$/ && !exists $wantr{"refs/$_"};
2331             "+refs/$_:".lrfetchrefs."/$_";
2332         } @specs;
2333
2334         my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2335         runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2336             @fspecs;
2337
2338         %lrfetchrefs_f = ();
2339         my %objgot;
2340
2341         git_for_each_ref(lrfetchrefs, sub {
2342             my ($objid,$objtype,$lrefname,$reftail) = @_;
2343             $lrfetchrefs_f{$lrefname} = $objid;
2344             $objgot{$objid} = 1;
2345         });
2346
2347         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2348             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2349             if (!exists $wantr{$rrefname}) {
2350                 if ($wanted_rref->($rrefname)) {
2351                     printdebug <<END;
2352 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2353 END
2354                 } else {
2355                     print STDERR <<END
2356 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2357 END
2358                 }
2359                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2360                 delete $lrfetchrefs_f{$lrefname};
2361                 next;
2362             }
2363         }
2364         foreach my $rrefname (sort keys %wantr) {
2365             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2366             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2367             my $want = $wantr{$rrefname};
2368             next if $got eq $want;
2369             if (!defined $objgot{$want}) {
2370                 print STDERR <<END;
2371 warning: git ls-remote suggests we want $lrefname
2372 warning:  and it should refer to $want
2373 warning:  but git fetch didn't fetch that object to any relevant ref.
2374 warning:  This may be due to a race with someone updating the server.
2375 warning:  Will try again...
2376 END
2377                 next FETCH_ITERATION;
2378             }
2379             printdebug <<END;
2380 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2381 END
2382             runcmd_ordryrun_local @git, qw(update-ref -m),
2383                 "dgit fetch git fetch fixup", $lrefname, $want;
2384             $lrfetchrefs_f{$lrefname} = $want;
2385         }
2386         last;
2387     }
2388     printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2389         Dumper(\%lrfetchrefs_f);
2390
2391     my %here;
2392     my @tagpats = debiantags('*',access_basedistro);
2393
2394     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2395         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2396         printdebug "currently $fullrefname=$objid\n";
2397         $here{$fullrefname} = $objid;
2398     });
2399     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2400         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2401         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2402         printdebug "offered $lref=$objid\n";
2403         if (!defined $here{$lref}) {
2404             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2405             runcmd_ordryrun_local @upd;
2406             lrfetchref_used $fullrefname;
2407         } elsif ($here{$lref} eq $objid) {
2408             lrfetchref_used $fullrefname;
2409         } else {
2410             print STDERR \
2411                 "Not updateting $lref from $here{$lref} to $objid.\n";
2412         }
2413     });
2414 }
2415
2416 sub mergeinfo_getclogp ($) {
2417     # Ensures thit $mi->{Clogp} exists and returns it
2418     my ($mi) = @_;
2419     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2420 }
2421
2422 sub mergeinfo_version ($) {
2423     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2424 }
2425
2426 sub fetch_from_archive () {
2427     ensure_setup_existing_tree();
2428
2429     # Ensures that lrref() is what is actually in the archive, one way
2430     # or another, according to us - ie this client's
2431     # appropritaely-updated archive view.  Also returns the commit id.
2432     # If there is nothing in the archive, leaves lrref alone and
2433     # returns undef.  git_fetch_us must have already been called.
2434     get_archive_dsc();
2435
2436     if ($dsc) {
2437         foreach my $field (@ourdscfield) {
2438             $dsc_hash = $dsc->{$field};
2439             last if defined $dsc_hash;
2440         }
2441         if (defined $dsc_hash) {
2442             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2443             $dsc_hash = $&;
2444             progress "last upload to archive specified git hash";
2445         } else {
2446             progress "last upload to archive has NO git hash";
2447         }
2448     } else {
2449         progress "no version available from the archive";
2450     }
2451
2452     # If the archive's .dsc has a Dgit field, there are three
2453     # relevant git commitids we need to choose between and/or merge
2454     # together:
2455     #   1. $dsc_hash: the Dgit field from the archive
2456     #   2. $lastpush_hash: the suite branch on the dgit git server
2457     #   3. $lastfetch_hash: our local tracking brach for the suite
2458     #
2459     # These may all be distinct and need not be in any fast forward
2460     # relationship:
2461     #
2462     # If the dsc was pushed to this suite, then the server suite
2463     # branch will have been updated; but it might have been pushed to
2464     # a different suite and copied by the archive.  Conversely a more
2465     # recent version may have been pushed with dgit but not appeared
2466     # in the archive (yet).
2467     #
2468     # $lastfetch_hash may be awkward because archive imports
2469     # (particularly, imports of Dgit-less .dscs) are performed only as
2470     # needed on individual clients, so different clients may perform a
2471     # different subset of them - and these imports are only made
2472     # public during push.  So $lastfetch_hash may represent a set of
2473     # imports different to a subsequent upload by a different dgit
2474     # client.
2475     #
2476     # Our approach is as follows:
2477     #
2478     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2479     # descendant of $dsc_hash, then it was pushed by a dgit user who
2480     # had based their work on $dsc_hash, so we should prefer it.
2481     # Otherwise, $dsc_hash was installed into this suite in the
2482     # archive other than by a dgit push, and (necessarily) after the
2483     # last dgit push into that suite (since a dgit push would have
2484     # been descended from the dgit server git branch); thus, in that
2485     # case, we prefer the archive's version (and produce a
2486     # pseudo-merge to overwrite the dgit server git branch).
2487     #
2488     # (If there is no Dgit field in the archive's .dsc then
2489     # generate_commit_from_dsc uses the version numbers to decide
2490     # whether the suite branch or the archive is newer.  If the suite
2491     # branch is newer it ignores the archive's .dsc; otherwise it
2492     # generates an import of the .dsc, and produces a pseudo-merge to
2493     # overwrite the suite branch with the archive contents.)
2494     #
2495     # The outcome of that part of the algorithm is the `public view',
2496     # and is same for all dgit clients: it does not depend on any
2497     # unpublished history in the local tracking branch.
2498     #
2499     # As between the public view and the local tracking branch: The
2500     # local tracking branch is only updated by dgit fetch, and
2501     # whenever dgit fetch runs it includes the public view in the
2502     # local tracking branch.  Therefore if the public view is not
2503     # descended from the local tracking branch, the local tracking
2504     # branch must contain history which was imported from the archive
2505     # but never pushed; and, its tip is now out of date.  So, we make
2506     # a pseudo-merge to overwrite the old imports and stitch the old
2507     # history in.
2508     #
2509     # Finally: we do not necessarily reify the public view (as
2510     # described above).  This is so that we do not end up stacking two
2511     # pseudo-merges.  So what we actually do is figure out the inputs
2512     # to any public view pseudo-merge and put them in @mergeinputs.
2513
2514     my @mergeinputs;
2515     # $mergeinputs[]{Commit}
2516     # $mergeinputs[]{Info}
2517     # $mergeinputs[0] is the one whose tree we use
2518     # @mergeinputs is in the order we use in the actual commit)
2519     #
2520     # Also:
2521     # $mergeinputs[]{Message} is a commit message to use
2522     # $mergeinputs[]{ReverseParents} if def specifies that parent
2523     #                                list should be in opposite order
2524     # Such an entry has no Commit or Info.  It applies only when found
2525     # in the last entry.  (This ugliness is to support making
2526     # identical imports to previous dgit versions.)
2527
2528     my $lastpush_hash = git_get_ref(lrfetchref());
2529     printdebug "previous reference hash=$lastpush_hash\n";
2530     $lastpush_mergeinput = $lastpush_hash && {
2531         Commit => $lastpush_hash,
2532         Info => "dgit suite branch on dgit git server",
2533     };
2534
2535     my $lastfetch_hash = git_get_ref(lrref());
2536     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2537     my $lastfetch_mergeinput = $lastfetch_hash && {
2538         Commit => $lastfetch_hash,
2539         Info => "dgit client's archive history view",
2540     };
2541
2542     my $dsc_mergeinput = $dsc_hash && {
2543         Commit => $dsc_hash,
2544         Info => "Dgit field in .dsc from archive",
2545     };
2546
2547     my $cwd = getcwd();
2548     my $del_lrfetchrefs = sub {
2549         changedir $cwd;
2550         my $gur;
2551         printdebug "del_lrfetchrefs...\n";
2552         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2553             my $objid = $lrfetchrefs_d{$fullrefname};
2554             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2555             if (!$gur) {
2556                 $gur ||= new IO::Handle;
2557                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2558             }
2559             printf $gur "delete %s %s\n", $fullrefname, $objid;
2560         }
2561         if ($gur) {
2562             close $gur or failedcmd "git update-ref delete lrfetchrefs";
2563         }
2564     };
2565
2566     if (defined $dsc_hash) {
2567         fail "missing remote git history even though dsc has hash -".
2568             " could not find ref ".rref()." at ".access_giturl()
2569             unless $lastpush_hash;
2570         ensure_we_have_orig();
2571         if ($dsc_hash eq $lastpush_hash) {
2572             @mergeinputs = $dsc_mergeinput
2573         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2574             print STDERR <<END or die $!;
2575
2576 Git commit in archive is behind the last version allegedly pushed/uploaded.
2577 Commit referred to by archive: $dsc_hash
2578 Last version pushed with dgit: $lastpush_hash
2579 $later_warning_msg
2580 END
2581             @mergeinputs = ($lastpush_mergeinput);
2582         } else {
2583             # Archive has .dsc which is not a descendant of the last dgit
2584             # push.  This can happen if the archive moves .dscs about.
2585             # Just follow its lead.
2586             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2587                 progress "archive .dsc names newer git commit";
2588                 @mergeinputs = ($dsc_mergeinput);
2589             } else {
2590                 progress "archive .dsc names other git commit, fixing up";
2591                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2592             }
2593         }
2594     } elsif ($dsc) {
2595         @mergeinputs = generate_commits_from_dsc();
2596         # We have just done an import.  Now, our import algorithm might
2597         # have been improved.  But even so we do not want to generate
2598         # a new different import of the same package.  So if the
2599         # version numbers are the same, just use our existing version.
2600         # If the version numbers are different, the archive has changed
2601         # (perhaps, rewound).
2602         if ($lastfetch_mergeinput &&
2603             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2604                               (mergeinfo_version $mergeinputs[0]) )) {
2605             @mergeinputs = ($lastfetch_mergeinput);
2606         }
2607     } elsif ($lastpush_hash) {
2608         # only in git, not in the archive yet
2609         @mergeinputs = ($lastpush_mergeinput);
2610         print STDERR <<END or die $!;
2611
2612 Package not found in the archive, but has allegedly been pushed using dgit.
2613 $later_warning_msg
2614 END
2615     } else {
2616         printdebug "nothing found!\n";
2617         if (defined $skew_warning_vsn) {
2618             print STDERR <<END or die $!;
2619
2620 Warning: relevant archive skew detected.
2621 Archive allegedly contains $skew_warning_vsn
2622 But we were not able to obtain any version from the archive or git.
2623
2624 END
2625         }
2626         unshift @end, $del_lrfetchrefs;
2627         return undef;
2628     }
2629
2630     if ($lastfetch_hash &&
2631         !grep {
2632             my $h = $_->{Commit};
2633             $h and is_fast_fwd($lastfetch_hash, $h);
2634             # If true, one of the existing parents of this commit
2635             # is a descendant of the $lastfetch_hash, so we'll
2636             # be ff from that automatically.
2637         } @mergeinputs
2638         ) {
2639         # Otherwise:
2640         push @mergeinputs, $lastfetch_mergeinput;
2641     }
2642
2643     printdebug "fetch mergeinfos:\n";
2644     foreach my $mi (@mergeinputs) {
2645         if ($mi->{Info}) {
2646             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2647         } else {
2648             printdebug sprintf " ReverseParents=%d Message=%s",
2649                 $mi->{ReverseParents}, $mi->{Message};
2650         }
2651     }
2652
2653     my $compat_info= pop @mergeinputs
2654         if $mergeinputs[$#mergeinputs]{Message};
2655
2656     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2657
2658     my $hash;
2659     if (@mergeinputs > 1) {
2660         # here we go, then:
2661         my $tree_commit = $mergeinputs[0]{Commit};
2662
2663         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2664         $tree =~ m/\n\n/;  $tree = $`;
2665         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2666         $tree = $1;
2667
2668         # We use the changelog author of the package in question the
2669         # author of this pseudo-merge.  This is (roughly) correct if
2670         # this commit is simply representing aa non-dgit upload.
2671         # (Roughly because it does not record sponsorship - but we
2672         # don't have sponsorship info because that's in the .changes,
2673         # which isn't in the archivw.)
2674         #
2675         # But, it might be that we are representing archive history
2676         # updates (including in-archive copies).  These are not really
2677         # the responsibility of the person who created the .dsc, but
2678         # there is no-one whose name we should better use.  (The
2679         # author of the .dsc-named commit is clearly worse.)
2680
2681         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2682         my $author = clogp_authline $useclogp;
2683         my $cversion = getfield $useclogp, 'Version';
2684
2685         my $mcf = ".git/dgit/mergecommit";
2686         open MC, ">", $mcf or die "$mcf $!";
2687         print MC <<END or die $!;
2688 tree $tree
2689 END
2690
2691         my @parents = grep { $_->{Commit} } @mergeinputs;
2692         @parents = reverse @parents if $compat_info->{ReverseParents};
2693         print MC <<END or die $! foreach @parents;
2694 parent $_->{Commit}
2695 END
2696
2697         print MC <<END or die $!;
2698 author $author
2699 committer $author
2700
2701 END
2702
2703         if (defined $compat_info->{Message}) {
2704             print MC $compat_info->{Message} or die $!;
2705         } else {
2706             print MC <<END or die $!;
2707 Record $package ($cversion) in archive suite $csuite
2708
2709 Record that
2710 END
2711             my $message_add_info = sub {
2712                 my ($mi) = (@_);
2713                 my $mversion = mergeinfo_version $mi;
2714                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2715                     or die $!;
2716             };
2717
2718             $message_add_info->($mergeinputs[0]);
2719             print MC <<END or die $!;
2720 should be treated as descended from
2721 END
2722             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2723         }
2724
2725         close MC or die $!;
2726         $hash = make_commit $mcf;
2727     } else {
2728         $hash = $mergeinputs[0]{Commit};
2729     }
2730     printdebug "fetch hash=$hash\n";
2731
2732     my $chkff = sub {
2733         my ($lasth, $what) = @_;
2734         return unless $lasth;
2735         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2736     };
2737
2738     $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2739     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2740
2741     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2742             'DGIT_ARCHIVE', $hash;
2743     cmdoutput @git, qw(log -n2), $hash;
2744     # ... gives git a chance to complain if our commit is malformed
2745
2746     if (defined $skew_warning_vsn) {
2747         mkpath '.git/dgit';
2748         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2749         my $gotclogp = commit_getclogp($hash);
2750         my $got_vsn = getfield $gotclogp, 'Version';
2751         printdebug "SKEW CHECK GOT $got_vsn\n";
2752         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2753             print STDERR <<END or die $!;
2754
2755 Warning: archive skew detected.  Using the available version:
2756 Archive allegedly contains    $skew_warning_vsn
2757 We were able to obtain only   $got_vsn
2758
2759 END
2760         }
2761     }
2762
2763     if ($lastfetch_hash ne $hash) {
2764         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2765         if (act_local()) {
2766             cmdoutput @upd_cmd;
2767         } else {
2768             dryrun_report @upd_cmd;
2769         }
2770     }
2771
2772     lrfetchref_used lrfetchref();
2773
2774     unshift @end, $del_lrfetchrefs;
2775     return $hash;
2776 }
2777
2778 sub set_local_git_config ($$) {
2779     my ($k, $v) = @_;
2780     runcmd @git, qw(config), $k, $v;
2781 }
2782
2783 sub setup_mergechangelogs (;$) {
2784     my ($always) = @_;
2785     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2786
2787     my $driver = 'dpkg-mergechangelogs';
2788     my $cb = "merge.$driver";
2789     my $attrs = '.git/info/attributes';
2790     ensuredir '.git/info';
2791
2792     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2793     if (!open ATTRS, "<", $attrs) {
2794         $!==ENOENT or die "$attrs: $!";
2795     } else {
2796         while (<ATTRS>) {
2797             chomp;
2798             next if m{^debian/changelog\s};
2799             print NATTRS $_, "\n" or die $!;
2800         }
2801         ATTRS->error and die $!;
2802         close ATTRS;
2803     }
2804     print NATTRS "debian/changelog merge=$driver\n" or die $!;
2805     close NATTRS;
2806
2807     set_local_git_config "$cb.name", 'debian/changelog merge driver';
2808     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2809
2810     rename "$attrs.new", "$attrs" or die "$attrs: $!";
2811 }
2812
2813 sub setup_useremail (;$) {
2814     my ($always) = @_;
2815     return unless $always || access_cfg_bool(1, 'setup-useremail');
2816
2817     my $setup = sub {
2818         my ($k, $envvar) = @_;
2819         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2820         return unless defined $v;
2821         set_local_git_config "user.$k", $v;
2822     };
2823
2824     $setup->('email', 'DEBEMAIL');
2825     $setup->('name', 'DEBFULLNAME');
2826 }
2827
2828 sub ensure_setup_existing_tree () {
2829     my $k = "remote.$remotename.skipdefaultupdate";
2830     my $c = git_get_config $k;
2831     return if defined $c;
2832     set_local_git_config $k, 'true';
2833 }
2834
2835 sub setup_new_tree () {
2836     setup_mergechangelogs();
2837     setup_useremail();
2838 }
2839
2840 sub clone ($) {
2841     my ($dstdir) = @_;
2842     canonicalise_suite();
2843     badusage "dry run makes no sense with clone" unless act_local();
2844     my $hasgit = check_for_git();
2845     mkdir $dstdir or fail "create \`$dstdir': $!";
2846     changedir $dstdir;
2847     runcmd @git, qw(init -q);
2848     my $giturl = access_giturl(1);
2849     if (defined $giturl) {
2850         open H, "> .git/HEAD" or die $!;
2851         print H "ref: ".lref()."\n" or die $!;
2852         close H or die $!;
2853         runcmd @git, qw(remote add), 'origin', $giturl;
2854     }
2855     if ($hasgit) {
2856         progress "fetching existing git history";
2857         git_fetch_us();
2858         runcmd_ordryrun_local @git, qw(fetch origin);
2859     } else {
2860         progress "starting new git history";
2861     }
2862     fetch_from_archive() or no_such_package;
2863     my $vcsgiturl = $dsc->{'Vcs-Git'};
2864     if (length $vcsgiturl) {
2865         $vcsgiturl =~ s/\s+-b\s+\S+//g;
2866         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2867     }
2868     setup_new_tree();
2869     runcmd @git, qw(reset --hard), lrref();
2870     printdone "ready for work in $dstdir";
2871 }
2872
2873 sub fetch () {
2874     if (check_for_git()) {
2875         git_fetch_us();
2876     }
2877     fetch_from_archive() or no_such_package();
2878     printdone "fetched into ".lrref();
2879 }
2880
2881 sub pull () {
2882     fetch();
2883     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2884         lrref();
2885     printdone "fetched to ".lrref()." and merged into HEAD";
2886 }
2887
2888 sub check_not_dirty () {
2889     foreach my $f (qw(local-options local-patch-header)) {
2890         if (stat_exists "debian/source/$f") {
2891             fail "git tree contains debian/source/$f";
2892         }
2893     }
2894
2895     return if $ignoredirty;
2896
2897     my @cmd = (@git, qw(diff --quiet HEAD));
2898     debugcmd "+",@cmd;
2899     $!=0; $?=-1; system @cmd;
2900     return if !$?;
2901     if ($?==256) {
2902         fail "working tree is dirty (does not match HEAD)";
2903     } else {
2904         failedcmd @cmd;
2905     }
2906 }
2907
2908 sub commit_admin ($) {
2909     my ($m) = @_;
2910     progress "$m";
2911     runcmd_ordryrun_local @git, qw(commit -m), $m;
2912 }
2913
2914 sub commit_quilty_patch () {
2915     my $output = cmdoutput @git, qw(status --porcelain);
2916     my %adds;
2917     foreach my $l (split /\n/, $output) {
2918         next unless $l =~ m/\S/;
2919         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2920             $adds{$1}++;
2921         }
2922     }
2923     delete $adds{'.pc'}; # if there wasn't one before, don't add it
2924     if (!%adds) {
2925         progress "nothing quilty to commit, ok.";
2926         return;
2927     }
2928     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2929     runcmd_ordryrun_local @git, qw(add -f), @adds;
2930     commit_admin <<END
2931 Commit Debian 3.0 (quilt) metadata
2932
2933 [dgit ($our_version) quilt-fixup]
2934 END
2935 }
2936
2937 sub get_source_format () {
2938     my %options;
2939     if (open F, "debian/source/options") {
2940         while (<F>) {
2941             next if m/^\s*\#/;
2942             next unless m/\S/;
2943             s/\s+$//; # ignore missing final newline
2944             if (m/\s*\#\s*/) {
2945                 my ($k, $v) = ($`, $'); #');
2946                 $v =~ s/^"(.*)"$/$1/;
2947                 $options{$k} = $v;
2948             } else {
2949                 $options{$_} = 1;
2950             }
2951         }
2952         F->error and die $!;
2953         close F;
2954     } else {
2955         die $! unless $!==&ENOENT;
2956     }
2957
2958     if (!open F, "debian/source/format") {
2959         die $! unless $!==&ENOENT;
2960         return '';
2961     }
2962     $_ = <F>;
2963     F->error and die $!;
2964     chomp;
2965     return ($_, \%options);
2966 }
2967
2968 sub madformat_wantfixup ($) {
2969     my ($format) = @_;
2970     return 0 unless $format eq '3.0 (quilt)';
2971     our $quilt_mode_warned;
2972     if ($quilt_mode eq 'nocheck') {
2973         progress "Not doing any fixup of \`$format' due to".
2974             " ----no-quilt-fixup or --quilt=nocheck"
2975             unless $quilt_mode_warned++;
2976         return 0;
2977     }
2978     progress "Format \`$format', need to check/update patch stack"
2979         unless $quilt_mode_warned++;
2980     return 1;
2981 }
2982
2983 # An "infopair" is a tuple [ $thing, $what ]
2984 # (often $thing is a commit hash; $what is a description)
2985
2986 sub infopair_cond_equal ($$) {
2987     my ($x,$y) = @_;
2988     $x->[0] eq $y->[0] or fail <<END;
2989 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2990 END
2991 };
2992
2993 sub infopair_lrf_tag_lookup ($$) {
2994     my ($tagnames, $what) = @_;
2995     # $tagname may be an array ref
2996     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2997     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2998     foreach my $tagname (@tagnames) {
2999         my $lrefname = lrfetchrefs."/tags/$tagname";
3000         my $tagobj = $lrfetchrefs_f{$lrefname};
3001         next unless defined $tagobj;
3002         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3003         return [ git_rev_parse($tagobj), $what ];
3004     }
3005     fail @tagnames==1 ? <<END : <<END;
3006 Wanted tag $what (@tagnames) on dgit server, but not found
3007 END
3008 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3009 END
3010 }
3011
3012 sub infopair_cond_ff ($$) {
3013     my ($anc,$desc) = @_;
3014     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3015 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3016 END
3017 };
3018
3019 sub pseudomerge_version_check ($$) {
3020     my ($clogp, $archive_hash) = @_;
3021
3022     my $arch_clogp = commit_getclogp $archive_hash;
3023     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3024                      'version currently in archive' ];
3025     if (defined $overwrite_version) {
3026         if (length $overwrite_version) {
3027             infopair_cond_equal([ $overwrite_version,
3028                                   '--overwrite= version' ],
3029                                 $i_arch_v);
3030         } else {
3031             my $v = $i_arch_v->[0];
3032             progress "Checking package changelog for archive version $v ...";
3033             eval {
3034                 my @xa = ("-f$v", "-t$v");
3035                 my $vclogp = parsechangelog @xa;
3036                 my $cv = [ (getfield $vclogp, 'Version'),
3037                            "Version field from dpkg-parsechangelog @xa" ];
3038                 infopair_cond_equal($i_arch_v, $cv);
3039             };
3040             if ($@) {
3041                 $@ =~ s/^dgit: //gm;
3042                 fail "$@".
3043                     "Perhaps debian/changelog does not mention $v ?";
3044             }
3045         }
3046     }
3047     
3048     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3049     return $i_arch_v;
3050 }
3051
3052 sub pseudomerge_make_commit ($$$$ $$) {
3053     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3054         $msg_cmd, $msg_msg) = @_;
3055     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3056
3057     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3058     my $authline = clogp_authline $clogp;
3059
3060     chomp $msg_msg;
3061     $msg_cmd .=
3062         !defined $overwrite_version ? ""
3063         : !length  $overwrite_version ? " --overwrite"
3064         : " --overwrite=".$overwrite_version;
3065
3066     mkpath '.git/dgit';
3067     my $pmf = ".git/dgit/pseudomerge";
3068     open MC, ">", $pmf or die "$pmf $!";
3069     print MC <<END or die $!;
3070 tree $tree
3071 parent $dgitview
3072 parent $archive_hash
3073 author $authline
3074 commiter $authline
3075
3076 $msg_msg
3077
3078 [$msg_cmd]
3079 END
3080     close MC or die $!;
3081
3082     return make_commit($pmf);
3083 }
3084
3085 sub splitbrain_pseudomerge ($$$$) {
3086     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3087     # => $merged_dgitview
3088     printdebug "splitbrain_pseudomerge...\n";
3089     #
3090     #     We:      debian/PREVIOUS    HEAD($maintview)
3091     # expect:          o ----------------- o
3092     #                    \                   \
3093     #                     o                   o
3094     #                 a/d/PREVIOUS        $dgitview
3095     #                $archive_hash              \
3096     #  If so,                \                   \
3097     #  we do:                 `------------------ o
3098     #   this:                                   $dgitview'
3099     #
3100
3101     return $dgitview unless defined $archive_hash;
3102
3103     printdebug "splitbrain_pseudomerge...\n";
3104
3105     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3106
3107     if (!defined $overwrite_version) {
3108         progress "Checking that HEAD inciudes all changes in archive...";
3109     }
3110
3111     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3112
3113     if (defined $overwrite_version) {
3114     } elsif (!eval {
3115         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
3116         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3117         my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
3118         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3119         my $i_archive = [ $archive_hash, "current archive contents" ];
3120
3121         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3122
3123         infopair_cond_equal($i_dgit, $i_archive);
3124         infopair_cond_ff($i_dep14, $i_dgit);
3125         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3126         1;
3127     }) {
3128         print STDERR <<END;
3129 $us: check failed (maybe --overwrite is needed, consult documentation)
3130 END
3131         die "$@";
3132     }
3133
3134     my $r = pseudomerge_make_commit
3135         $clogp, $dgitview, $archive_hash, $i_arch_v,
3136         "dgit --quilt=$quilt_mode",
3137         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3138 Declare fast forward from $i_arch_v->[0]
3139 END_OVERWR
3140 Make fast forward from $i_arch_v->[0]
3141 END_MAKEFF
3142
3143     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3144     return $r;
3145 }       
3146
3147 sub plain_overwrite_pseudomerge ($$$) {
3148     my ($clogp, $head, $archive_hash) = @_;
3149
3150     printdebug "plain_overwrite_pseudomerge...";
3151
3152     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3153
3154     return $head if is_fast_fwd $archive_hash, $head;
3155
3156     my $m = "Declare fast forward from $i_arch_v->[0]";
3157
3158     my $r = pseudomerge_make_commit
3159         $clogp, $head, $archive_hash, $i_arch_v,
3160         "dgit", $m;
3161
3162     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3163
3164     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3165     return $r;
3166 }
3167
3168 sub push_parse_changelog ($) {
3169     my ($clogpfn) = @_;
3170
3171     my $clogp = Dpkg::Control::Hash->new();
3172     $clogp->load($clogpfn) or die;
3173
3174     $package = getfield $clogp, 'Source';
3175     my $cversion = getfield $clogp, 'Version';
3176     my $tag = debiantag($cversion, access_basedistro);
3177     runcmd @git, qw(check-ref-format), $tag;
3178
3179     my $dscfn = dscfn($cversion);
3180
3181     return ($clogp, $cversion, $dscfn);
3182 }
3183
3184 sub push_parse_dsc ($$$) {
3185     my ($dscfn,$dscfnwhat, $cversion) = @_;
3186     $dsc = parsecontrol($dscfn,$dscfnwhat);
3187     my $dversion = getfield $dsc, 'Version';
3188     my $dscpackage = getfield $dsc, 'Source';
3189     ($dscpackage eq $package && $dversion eq $cversion) or
3190         fail "$dscfn is for $dscpackage $dversion".
3191             " but debian/changelog is for $package $cversion";
3192 }
3193
3194 sub push_tagwants ($$$$) {
3195     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3196     my @tagwants;
3197     push @tagwants, {
3198         TagFn => \&debiantag,
3199         Objid => $dgithead,
3200         TfSuffix => '',
3201         View => 'dgit',
3202     };
3203     if (defined $maintviewhead) {
3204         push @tagwants, {
3205             TagFn => \&debiantag_maintview,
3206             Objid => $maintviewhead,
3207             TfSuffix => '-maintview',
3208             View => 'maint',
3209         };
3210     }
3211     foreach my $tw (@tagwants) {
3212         $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
3213         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3214     }
3215     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3216     return @tagwants;
3217 }
3218
3219 sub push_mktags ($$ $$ $) {
3220     my ($clogp,$dscfn,
3221         $changesfile,$changesfilewhat,
3222         $tagwants) = @_;
3223
3224     die unless $tagwants->[0]{View} eq 'dgit';
3225
3226     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3227     $dsc->save("$dscfn.tmp") or die $!;
3228
3229     my $changes = parsecontrol($changesfile,$changesfilewhat);
3230     foreach my $field (qw(Source Distribution Version)) {
3231         $changes->{$field} eq $clogp->{$field} or
3232             fail "changes field $field \`$changes->{$field}'".
3233                 " does not match changelog \`$clogp->{$field}'";
3234     }
3235
3236     my $cversion = getfield $clogp, 'Version';
3237     my $clogsuite = getfield $clogp, 'Distribution';
3238
3239     # We make the git tag by hand because (a) that makes it easier
3240     # to control the "tagger" (b) we can do remote signing
3241     my $authline = clogp_authline $clogp;
3242     my $delibs = join(" ", "",@deliberatelies);
3243     my $declaredistro = access_basedistro();
3244
3245     my $mktag = sub {
3246         my ($tw) = @_;
3247         my $tfn = $tw->{Tfn};
3248         my $head = $tw->{Objid};
3249         my $tag = $tw->{Tag};
3250
3251         open TO, '>', $tfn->('.tmp') or die $!;
3252         print TO <<END or die $!;
3253 object $head
3254 type commit
3255 tag $tag
3256 tagger $authline
3257
3258 END
3259         if ($tw->{View} eq 'dgit') {
3260             print TO <<END or die $!;
3261 $package release $cversion for $clogsuite ($csuite) [dgit]
3262 [dgit distro=$declaredistro$delibs]
3263 END
3264             foreach my $ref (sort keys %previously) {
3265                 print TO <<END or die $!;
3266 [dgit previously:$ref=$previously{$ref}]
3267 END
3268             }
3269         } elsif ($tw->{View} eq 'maint') {
3270             print TO <<END or die $!;
3271 $package release $cversion for $clogsuite ($csuite)
3272 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3273 END
3274         } else {
3275             die Dumper($tw)."?";
3276         }
3277
3278         close TO or die $!;
3279
3280         my $tagobjfn = $tfn->('.tmp');
3281         if ($sign) {
3282             if (!defined $keyid) {
3283                 $keyid = access_cfg('keyid','RETURN-UNDEF');
3284             }
3285             if (!defined $keyid) {
3286                 $keyid = getfield $clogp, 'Maintainer';
3287             }
3288             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3289             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3290             push @sign_cmd, qw(-u),$keyid if defined $keyid;
3291             push @sign_cmd, $tfn->('.tmp');
3292             runcmd_ordryrun @sign_cmd;
3293             if (act_scary()) {
3294                 $tagobjfn = $tfn->('.signed.tmp');
3295                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3296                     $tfn->('.tmp'), $tfn->('.tmp.asc');
3297             }
3298         }
3299         return $tagobjfn;
3300     };
3301
3302     my @r = map { $mktag->($_); } @$tagwants;
3303     return @r;
3304 }
3305
3306 sub sign_changes ($) {
3307     my ($changesfile) = @_;
3308     if ($sign) {
3309         my @debsign_cmd = @debsign;
3310         push @debsign_cmd, "-k$keyid" if defined $keyid;
3311         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3312         push @debsign_cmd, $changesfile;
3313         runcmd_ordryrun @debsign_cmd;
3314     }
3315 }
3316
3317 sub dopush () {
3318     printdebug "actually entering push\n";
3319
3320     supplementary_message(<<'END');
3321 Push failed, while checking state of the archive.
3322 You can retry the push, after fixing the problem, if you like.
3323 END
3324     if (check_for_git()) {
3325         git_fetch_us();
3326     }
3327     my $archive_hash = fetch_from_archive();
3328     if (!$archive_hash) {
3329         $new_package or
3330             fail "package appears to be new in this suite;".
3331                 " if this is intentional, use --new";
3332     }
3333
3334     supplementary_message(<<'END');
3335 Push failed, while preparing your push.
3336 You can retry the push, after fixing the problem, if you like.
3337 END
3338
3339     need_tagformat 'new', "quilt mode $quilt_mode"
3340         if quiltmode_splitbrain;
3341
3342     prep_ud();
3343
3344     access_giturl(); # check that success is vaguely likely
3345     select_tagformat();
3346
3347     my $clogpfn = ".git/dgit/changelog.822.tmp";
3348     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3349
3350     responder_send_file('parsed-changelog', $clogpfn);
3351
3352     my ($clogp, $cversion, $dscfn) =
3353         push_parse_changelog("$clogpfn");
3354
3355     my $dscpath = "$buildproductsdir/$dscfn";
3356     stat_exists $dscpath or
3357         fail "looked for .dsc $dscfn, but $!;".
3358             " maybe you forgot to build";
3359
3360     responder_send_file('dsc', $dscpath);
3361
3362     push_parse_dsc($dscpath, $dscfn, $cversion);
3363
3364     my $format = getfield $dsc, 'Format';
3365     printdebug "format $format\n";
3366
3367     my $actualhead = git_rev_parse('HEAD');
3368     my $dgithead = $actualhead;
3369     my $maintviewhead = undef;
3370
3371     my $upstreamversion = $clogp->{Version};
3372     $upstreamversion =~ s/-[^-]*$//;
3373
3374     if (madformat_wantfixup($format)) {
3375         # user might have not used dgit build, so maybe do this now:
3376         if (quiltmode_splitbrain()) {
3377             changedir $ud;
3378             quilt_make_fake_dsc($upstreamversion);
3379             my $cachekey;
3380             ($dgithead, $cachekey) =
3381                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3382             $dgithead or fail
3383  "--quilt=$quilt_mode but no cached dgit view:
3384  perhaps tree changed since dgit build[-source] ?";
3385             $split_brain = 1;
3386             $dgithead = splitbrain_pseudomerge($clogp,
3387                                                $actualhead, $dgithead,
3388                                                $archive_hash);
3389             $maintviewhead = $actualhead;
3390             changedir '../../../..';
3391             prep_ud(); # so _only_subdir() works, below
3392         } else {
3393             commit_quilty_patch();
3394         }
3395     }
3396
3397     if (defined $overwrite_version && !defined $maintviewhead) {
3398         $dgithead = plain_overwrite_pseudomerge($clogp,
3399                                                 $dgithead,
3400                                                 $archive_hash);
3401     }
3402
3403     check_not_dirty();
3404
3405     my $forceflag = '';
3406     if ($archive_hash) {
3407         if (is_fast_fwd($archive_hash, $dgithead)) {
3408             # ok
3409         } elsif (deliberately_not_fast_forward) {
3410             $forceflag = '+';
3411         } else {
3412             fail "dgit push: HEAD is not a descendant".
3413                 " of the archive's version.\n".
3414                 "To overwrite the archive's contents,".
3415                 " pass --overwrite[=VERSION].\n".
3416                 "To rewind history, if permitted by the archive,".
3417                 " use --deliberately-not-fast-forward.";
3418         }
3419     }
3420
3421     changedir $ud;
3422     progress "checking that $dscfn corresponds to HEAD";
3423     runcmd qw(dpkg-source -x --),
3424         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3425     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3426     check_for_vendor_patches() if madformat($dsc->{format});
3427     changedir '../../../..';
3428     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3429     debugcmd "+",@diffcmd;
3430     $!=0; $?=-1;
3431     my $r = system @diffcmd;
3432     if ($r) {
3433         if ($r==256) {
3434             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3435             fail <<END
3436 HEAD specifies a different tree to $dscfn:
3437 $diffs
3438 Perhaps you forgot to build.  Or perhaps there is a problem with your
3439  source tree (see dgit(7) for some hints).  To see a full diff, run
3440    git diff $tree HEAD
3441 END
3442         } else {
3443             failedcmd @diffcmd;
3444         }
3445     }
3446     if (!$changesfile) {
3447         my $pat = changespat $cversion;
3448         my @cs = glob "$buildproductsdir/$pat";
3449         fail "failed to find unique changes file".
3450             " (looked for $pat in $buildproductsdir);".
3451             " perhaps you need to use dgit -C"
3452             unless @cs==1;
3453         ($changesfile) = @cs;
3454     } else {
3455         $changesfile = "$buildproductsdir/$changesfile";
3456     }
3457
3458     # Check that changes and .dsc agree enough
3459     $changesfile =~ m{[^/]*$};
3460     my $changes = parsecontrol($changesfile,$&);
3461     files_compare_inputs($dsc, $changes)
3462         unless forceing [qw(dsc-changes-mismatch)];
3463
3464     # Perhaps adjust .dsc to contain right set of origs
3465     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3466                                   $changesfile)
3467         unless forceing [qw(changes-origs-exactly)];
3468
3469     # Checks complete, we're going to try and go ahead:
3470
3471     responder_send_file('changes',$changesfile);
3472     responder_send_command("param head $dgithead");
3473     responder_send_command("param csuite $csuite");
3474     responder_send_command("param tagformat $tagformat");
3475     if (defined $maintviewhead) {
3476         die unless ($protovsn//4) >= 4;
3477         responder_send_command("param maint-view $maintviewhead");
3478     }
3479
3480     if (deliberately_not_fast_forward) {
3481         git_for_each_ref(lrfetchrefs, sub {
3482             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3483             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3484             responder_send_command("previously $rrefname=$objid");
3485             $previously{$rrefname} = $objid;
3486         });
3487     }
3488
3489     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3490                                  ".git/dgit/tag");
3491     my @tagobjfns;
3492
3493     supplementary_message(<<'END');
3494 Push failed, while signing the tag.
3495 You can retry the push, after fixing the problem, if you like.
3496 END
3497     # If we manage to sign but fail to record it anywhere, it's fine.
3498     if ($we_are_responder) {
3499         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3500         responder_receive_files('signed-tag', @tagobjfns);
3501     } else {
3502         @tagobjfns = push_mktags($clogp,$dscpath,
3503                               $changesfile,$changesfile,
3504                               \@tagwants);
3505     }
3506     supplementary_message(<<'END');
3507 Push failed, *after* signing the tag.
3508 If you want to try again, you should use a new version number.
3509 END
3510
3511     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3512
3513     foreach my $tw (@tagwants) {
3514         my $tag = $tw->{Tag};
3515         my $tagobjfn = $tw->{TagObjFn};
3516         my $tag_obj_hash =
3517             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3518         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3519         runcmd_ordryrun_local
3520             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3521     }
3522
3523     supplementary_message(<<'END');
3524 Push failed, while updating the remote git repository - see messages above.
3525 If you want to try again, you should use a new version number.
3526 END
3527     if (!check_for_git()) {
3528         create_remote_git_repo();
3529     }
3530
3531     my @pushrefs = $forceflag.$dgithead.":".rrref();
3532     foreach my $tw (@tagwants) {
3533         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3534     }
3535
3536     runcmd_ordryrun @git,
3537         qw(-c push.followTags=false push), access_giturl(), @pushrefs;
3538     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3539
3540     supplementary_message(<<'END');
3541 Push failed, after updating the remote git repository.
3542 If you want to try again, you must use a new version number.
3543 END
3544     if ($we_are_responder) {
3545         my $dryrunsuffix = act_local() ? "" : ".tmp";
3546         responder_receive_files('signed-dsc-changes',
3547                                 "$dscpath$dryrunsuffix",
3548                                 "$changesfile$dryrunsuffix");
3549     } else {
3550         if (act_local()) {
3551             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3552         } else {
3553             progress "[new .dsc left in $dscpath.tmp]";
3554         }
3555         sign_changes $changesfile;
3556     }
3557
3558     supplementary_message(<<END);
3559 Push failed, while uploading package(s) to the archive server.
3560 You can retry the upload of exactly these same files with dput of:
3561   $changesfile
3562 If that .changes file is broken, you will need to use a new version
3563 number for your next attempt at the upload.
3564 END
3565     my $host = access_cfg('upload-host','RETURN-UNDEF');
3566     my @hostarg = defined($host) ? ($host,) : ();
3567     runcmd_ordryrun @dput, @hostarg, $changesfile;
3568     printdone "pushed and uploaded $cversion";
3569
3570     supplementary_message('');
3571     responder_send_command("complete");
3572 }
3573
3574 sub cmd_clone {
3575     parseopts();
3576     notpushing();
3577     my $dstdir;
3578     badusage "-p is not allowed with clone; specify as argument instead"
3579         if defined $package;
3580     if (@ARGV==1) {
3581         ($package) = @ARGV;
3582     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3583         ($package,$isuite) = @ARGV;
3584     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3585         ($package,$dstdir) = @ARGV;
3586     } elsif (@ARGV==3) {
3587         ($package,$isuite,$dstdir) = @ARGV;
3588     } else {
3589         badusage "incorrect arguments to dgit clone";
3590     }
3591     $dstdir ||= "$package";
3592
3593     if (stat_exists $dstdir) {
3594         fail "$dstdir already exists";
3595     }
3596
3597     my $cwd_remove;
3598     if ($rmonerror && !$dryrun_level) {
3599         $cwd_remove= getcwd();
3600         unshift @end, sub { 
3601             return unless defined $cwd_remove;
3602             if (!chdir "$cwd_remove") {
3603                 return if $!==&ENOENT;
3604                 die "chdir $cwd_remove: $!";
3605             }
3606             if (stat $dstdir) {
3607                 rmtree($dstdir) or die "remove $dstdir: $!\n";
3608             } elsif (grep { $! == $_ }
3609                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3610             } else {
3611                 print STDERR "check whether to remove $dstdir: $!\n";
3612             }
3613         };
3614     }
3615
3616     clone($dstdir);
3617     $cwd_remove = undef;
3618 }
3619
3620 sub branchsuite () {
3621     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3622     if ($branch =~ m#$lbranch_re#o) {
3623         return $1;
3624     } else {
3625         return undef;
3626     }
3627 }
3628
3629 sub fetchpullargs () {
3630     notpushing();
3631     if (!defined $package) {
3632         my $sourcep = parsecontrol('debian/control','debian/control');
3633         $package = getfield $sourcep, 'Source';
3634     }
3635     if (@ARGV==0) {
3636 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
3637         if (!$isuite) {
3638             my $clogp = parsechangelog();
3639             $isuite = getfield $clogp, 'Distribution';
3640         }
3641         canonicalise_suite();
3642         progress "fetching from suite $csuite";
3643     } elsif (@ARGV==1) {
3644         ($isuite) = @ARGV;
3645         canonicalise_suite();
3646     } else {
3647         badusage "incorrect arguments to dgit fetch or dgit pull";
3648     }
3649 }
3650
3651 sub cmd_fetch {
3652     parseopts();
3653     fetchpullargs();
3654     fetch();
3655 }
3656
3657 sub cmd_pull {
3658     parseopts();
3659     fetchpullargs();
3660     pull();
3661 }
3662
3663 sub cmd_push {
3664     parseopts();
3665     pushing();
3666     badusage "-p is not allowed with dgit push" if defined $package;
3667     check_not_dirty();
3668     my $clogp = parsechangelog();
3669     $package = getfield $clogp, 'Source';
3670     my $specsuite;
3671     if (@ARGV==0) {
3672     } elsif (@ARGV==1) {
3673         ($specsuite) = (@ARGV);
3674     } else {
3675         badusage "incorrect arguments to dgit push";
3676     }
3677     $isuite = getfield $clogp, 'Distribution';
3678     if ($new_package) {
3679         local ($package) = $existing_package; # this is a hack
3680         canonicalise_suite();
3681     } else {
3682         canonicalise_suite();
3683     }
3684     if (defined $specsuite &&
3685         $specsuite ne $isuite &&
3686         $specsuite ne $csuite) {
3687             fail "dgit push: changelog specifies $isuite ($csuite)".
3688                 " but command line specifies $specsuite";
3689     }
3690     dopush();
3691 }
3692
3693 #---------- remote commands' implementation ----------
3694
3695 sub cmd_remote_push_build_host {
3696     my ($nrargs) = shift @ARGV;
3697     my (@rargs) = @ARGV[0..$nrargs-1];
3698     @ARGV = @ARGV[$nrargs..$#ARGV];
3699     die unless @rargs;
3700     my ($dir,$vsnwant) = @rargs;
3701     # vsnwant is a comma-separated list; we report which we have
3702     # chosen in our ready response (so other end can tell if they
3703     # offered several)
3704     $debugprefix = ' ';
3705     $we_are_responder = 1;
3706     $us .= " (build host)";
3707
3708     pushing();
3709
3710     open PI, "<&STDIN" or die $!;
3711     open STDIN, "/dev/null" or die $!;
3712     open PO, ">&STDOUT" or die $!;
3713     autoflush PO 1;
3714     open STDOUT, ">&STDERR" or die $!;
3715     autoflush STDOUT 1;
3716
3717     $vsnwant //= 1;
3718     ($protovsn) = grep {
3719         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3720     } @rpushprotovsn_support;
3721
3722     fail "build host has dgit rpush protocol versions ".
3723         (join ",", @rpushprotovsn_support).
3724         " but invocation host has $vsnwant"
3725         unless defined $protovsn;
3726
3727     responder_send_command("dgit-remote-push-ready $protovsn");
3728     rpush_handle_protovsn_bothends();
3729     changedir $dir;
3730     &cmd_push;
3731 }
3732
3733 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3734 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3735 #     a good error message)
3736
3737 sub rpush_handle_protovsn_bothends () {
3738     if ($protovsn < 4) {
3739         need_tagformat 'old', "rpush negotiated protocol $protovsn";
3740     }
3741     select_tagformat();
3742 }
3743
3744 our $i_tmp;
3745
3746 sub i_cleanup {
3747     local ($@, $?);
3748     my $report = i_child_report();
3749     if (defined $report) {
3750         printdebug "($report)\n";
3751     } elsif ($i_child_pid) {
3752         printdebug "(killing build host child $i_child_pid)\n";
3753         kill 15, $i_child_pid;
3754     }
3755     if (defined $i_tmp && !defined $initiator_tempdir) {
3756         changedir "/";
3757         eval { rmtree $i_tmp; };
3758     }
3759 }
3760
3761 END { i_cleanup(); }
3762
3763 sub i_method {
3764     my ($base,$selector,@args) = @_;
3765     $selector =~ s/\-/_/g;
3766     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3767 }
3768
3769 sub cmd_rpush {
3770     pushing();
3771     my $host = nextarg;
3772     my $dir;
3773     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3774         $host = $1;
3775         $dir = $'; #';
3776     } else {
3777         $dir = nextarg;
3778     }
3779     $dir =~ s{^-}{./-};
3780     my @rargs = ($dir);
3781     push @rargs, join ",", @rpushprotovsn_support;
3782     my @rdgit;
3783     push @rdgit, @dgit;
3784     push @rdgit, @ropts;
3785     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3786     push @rdgit, @ARGV;
3787     my @cmd = (@ssh, $host, shellquote @rdgit);
3788     debugcmd "+",@cmd;
3789
3790     if (defined $initiator_tempdir) {
3791         rmtree $initiator_tempdir;
3792         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3793         $i_tmp = $initiator_tempdir;
3794     } else {
3795         $i_tmp = tempdir();
3796     }
3797     $i_child_pid = open2(\*RO, \*RI, @cmd);
3798     changedir $i_tmp;
3799     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3800     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3801     $supplementary_message = '' unless $protovsn >= 3;
3802
3803     fail "rpush negotiated protocol version $protovsn".
3804         " which does not support quilt mode $quilt_mode"
3805         if quiltmode_splitbrain;
3806
3807     rpush_handle_protovsn_bothends();
3808     for (;;) {
3809         my ($icmd,$iargs) = initiator_expect {
3810             m/^(\S+)(?: (.*))?$/;
3811             ($1,$2);
3812         };
3813         i_method "i_resp", $icmd, $iargs;
3814     }
3815 }
3816
3817 sub i_resp_progress ($) {
3818     my ($rhs) = @_;
3819     my $msg = protocol_read_bytes \*RO, $rhs;
3820     progress $msg;
3821 }
3822
3823 sub i_resp_supplementary_message ($) {
3824     my ($rhs) = @_;
3825     $supplementary_message = protocol_read_bytes \*RO, $rhs;
3826 }
3827
3828 sub i_resp_complete {
3829     my $pid = $i_child_pid;
3830     $i_child_pid = undef; # prevents killing some other process with same pid
3831     printdebug "waiting for build host child $pid...\n";
3832     my $got = waitpid $pid, 0;
3833     die $! unless $got == $pid;
3834     die "build host child failed $?" if $?;
3835
3836     i_cleanup();
3837     printdebug "all done\n";
3838     exit 0;
3839 }
3840
3841 sub i_resp_file ($) {
3842     my ($keyword) = @_;
3843     my $localname = i_method "i_localname", $keyword;
3844     my $localpath = "$i_tmp/$localname";
3845     stat_exists $localpath and
3846         badproto \*RO, "file $keyword ($localpath) twice";
3847     protocol_receive_file \*RO, $localpath;
3848     i_method "i_file", $keyword;
3849 }
3850
3851 our %i_param;
3852
3853 sub i_resp_param ($) {
3854     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3855     $i_param{$1} = $2;
3856 }
3857
3858 sub i_resp_previously ($) {
3859     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3860         or badproto \*RO, "bad previously spec";
3861     my $r = system qw(git check-ref-format), $1;
3862     die "bad previously ref spec ($r)" if $r;
3863     $previously{$1} = $2;
3864 }
3865
3866 our %i_wanted;
3867
3868 sub i_resp_want ($) {
3869     my ($keyword) = @_;
3870     die "$keyword ?" if $i_wanted{$keyword}++;
3871     my @localpaths = i_method "i_want", $keyword;
3872     printdebug "[[  $keyword @localpaths\n";
3873     foreach my $localpath (@localpaths) {
3874         protocol_send_file \*RI, $localpath;
3875     }
3876     print RI "files-end\n" or die $!;
3877 }
3878
3879 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3880
3881 sub i_localname_parsed_changelog {
3882     return "remote-changelog.822";
3883 }
3884 sub i_file_parsed_changelog {
3885     ($i_clogp, $i_version, $i_dscfn) =
3886         push_parse_changelog "$i_tmp/remote-changelog.822";
3887     die if $i_dscfn =~ m#/|^\W#;
3888 }
3889
3890 sub i_localname_dsc {
3891     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3892     return $i_dscfn;
3893 }
3894 sub i_file_dsc { }
3895
3896 sub i_localname_changes {
3897     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3898     $i_changesfn = $i_dscfn;
3899     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3900     return $i_changesfn;
3901 }
3902 sub i_file_changes { }
3903
3904 sub i_want_signed_tag {
3905     printdebug Dumper(\%i_param, $i_dscfn);
3906     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3907         && defined $i_param{'csuite'}
3908         or badproto \*RO, "premature desire for signed-tag";
3909     my $head = $i_param{'head'};
3910     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3911
3912     my $maintview = $i_param{'maint-view'};
3913     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3914
3915     select_tagformat();
3916     if ($protovsn >= 4) {
3917         my $p = $i_param{'tagformat'} // '<undef>';
3918         $p eq $tagformat
3919             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3920     }
3921
3922     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3923     $csuite = $&;
3924     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3925
3926     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3927
3928     return
3929         push_mktags $i_clogp, $i_dscfn,
3930             $i_changesfn, 'remote changes',
3931             \@tagwants;
3932 }
3933
3934 sub i_want_signed_dsc_changes {
3935     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3936     sign_changes $i_changesfn;
3937     return ($i_dscfn, $i_changesfn);
3938 }
3939
3940 #---------- building etc. ----------
3941
3942 our $version;
3943 our $sourcechanges;
3944 our $dscfn;
3945
3946 #----- `3.0 (quilt)' handling -----
3947
3948 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3949
3950 sub quiltify_dpkg_commit ($$$;$) {
3951     my ($patchname,$author,$msg, $xinfo) = @_;
3952     $xinfo //= '';
3953
3954     mkpath '.git/dgit';
3955     my $descfn = ".git/dgit/quilt-description.tmp";
3956     open O, '>', $descfn or die "$descfn: $!";
3957     $msg =~ s/\n+/\n\n/;
3958     print O <<END or die $!;
3959 From: $author
3960 ${xinfo}Subject: $msg
3961 ---
3962
3963 END
3964     close O or die $!;
3965
3966     {
3967         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3968         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3969         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3970         runcmd @dpkgsource, qw(--commit .), $patchname;
3971     }
3972 }
3973
3974 sub quiltify_trees_differ ($$;$$$) {
3975     my ($x,$y,$finegrained,$ignorenamesr,$unrepres) = @_;
3976     # returns true iff the two tree objects differ other than in debian/
3977     # with $finegrained,
3978     # returns bitmask 01 - differ in upstream files except .gitignore
3979     #                 02 - differ in .gitignore
3980     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3981     #  is set for each modified .gitignore filename $fn
3982     # if $unrepres is defined, array ref to which is appeneded
3983     #  a list of unrepresentable changes (removals of upstream files
3984     #  (as messages)
3985     local $/=undef;
3986     my @cmd = (@git, qw(diff-tree -z));
3987     push @cmd, qw(--name-only) unless $unrepres;
3988     push @cmd, qw(-r) if $finegrained || $unrepres;
3989     push @cmd, $x, $y;
3990     my $diffs= cmdoutput @cmd;
3991     my $r = 0;
3992     my @lmodes;
3993     foreach my $f (split /\0/, $diffs) {
3994         if ($unrepres && !@lmodes) {
3995             @lmodes = $f =~ m/^\:(\w+) (\w+) \w+ \w+ / or die "$_ ?";
3996             next;
3997         }
3998         my ($oldmode,$newmode) = @lmodes;
3999         @lmodes = ();
4000
4001         next if $f =~ m#^debian(?:/.*)?$#s;
4002
4003         if ($unrepres) {
4004             eval {
4005                 die "deleted\n" unless $newmode =~ m/[^0]/;
4006                 die "not a plain file\n" unless $newmode =~ m/^10\d{4}$/;
4007                 if ($oldmode =~ m/[^0]/) {
4008                     die "mode changed\n" if $oldmode ne $newmode;
4009                 } else {
4010                     die "non-default mode\n" unless $newmode =~ m/^100644$/;
4011                 }
4012             };
4013             if ($@) {
4014                 local $/="\n"; chomp $@;
4015                 push @$unrepres, [ $f, $@ ];
4016             }
4017         }
4018
4019         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
4020         $r |= $isignore ? 02 : 01;
4021         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
4022     }
4023     printdebug "quiltify_trees_differ $x $y => $r\n";
4024     return $r;
4025 }
4026
4027 sub quiltify_tree_sentinelfiles ($) {
4028     # lists the `sentinel' files present in the tree
4029     my ($x) = @_;
4030     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
4031         qw(-- debian/rules debian/control);
4032     $r =~ s/\n/,/g;
4033     return $r;
4034 }
4035
4036 sub quiltify_splitbrain_needed () {
4037     if (!$split_brain) {
4038         progress "dgit view: changes are required...";
4039         runcmd @git, qw(checkout -q -b dgit-view);
4040         $split_brain = 1;
4041     }
4042 }
4043
4044 sub quiltify_splitbrain ($$$$$$) {
4045     my ($clogp, $unapplied, $headref, $diffbits,
4046         $editedignores, $cachekey) = @_;
4047     if ($quilt_mode !~ m/gbp|dpm/) {
4048         # treat .gitignore just like any other upstream file
4049         $diffbits = { %$diffbits };
4050         $_ = !!$_ foreach values %$diffbits;
4051     }
4052     # We would like any commits we generate to be reproducible
4053     my @authline = clogp_authline($clogp);
4054     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
4055     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
4056     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
4057     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
4058     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
4059     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
4060
4061     if ($quilt_mode =~ m/gbp|unapplied/ &&
4062         ($diffbits->{O2H} & 01)) {
4063         my $msg =
4064  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
4065  " but git tree differs from orig in upstream files.";
4066         if (!stat_exists "debian/patches") {
4067             $msg .=
4068  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
4069         }  
4070         fail $msg;
4071     }
4072     if ($quilt_mode =~ m/dpm/ &&
4073         ($diffbits->{H2A} & 01)) {
4074         fail <<END;
4075 --quilt=$quilt_mode specified, implying patches-applied git tree
4076  but git tree differs from result of applying debian/patches to upstream
4077 END
4078     }
4079     if ($quilt_mode =~ m/gbp|unapplied/ &&
4080         ($diffbits->{O2A} & 01)) { # some patches
4081         quiltify_splitbrain_needed();
4082         progress "dgit view: creating patches-applied version using gbp pq";
4083         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
4084         # gbp pq import creates a fresh branch; push back to dgit-view
4085         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
4086         runcmd @git, qw(checkout -q dgit-view);
4087     }
4088     if ($quilt_mode =~ m/gbp|dpm/ &&
4089         ($diffbits->{O2A} & 02)) {
4090         fail <<END
4091 --quilt=$quilt_mode specified, implying that HEAD is for use with a
4092  tool which does not create patches for changes to upstream
4093  .gitignores: but, such patches exist in debian/patches.
4094 END
4095     }
4096     if (($diffbits->{O2H} & 02) && # user has modified .gitignore
4097         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
4098         quiltify_splitbrain_needed();
4099         progress "dgit view: creating patch to represent .gitignore changes";
4100         ensuredir "debian/patches";
4101         my $gipatch = "debian/patches/auto-gitignore";
4102         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
4103         stat GIPATCH or die "$gipatch: $!";
4104         fail "$gipatch already exists; but want to create it".
4105             " to record .gitignore changes" if (stat _)[7];
4106         print GIPATCH <<END or die "$gipatch: $!";
4107 Subject: Update .gitignore from Debian packaging branch
4108
4109 The Debian packaging git branch contains these updates to the upstream
4110 .gitignore file(s).  This patch is autogenerated, to provide these
4111 updates to users of the official Debian archive view of the package.
4112
4113 [dgit ($our_version) update-gitignore]
4114 ---
4115 END
4116         close GIPATCH or die "$gipatch: $!";
4117         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
4118             $unapplied, $headref, "--", sort keys %$editedignores;
4119         open SERIES, "+>>", "debian/patches/series" or die $!;
4120         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
4121         my $newline;
4122         defined read SERIES, $newline, 1 or die $!;
4123         print SERIES "\n" or die $! unless $newline eq "\n";
4124         print SERIES "auto-gitignore\n" or die $!;
4125         close SERIES or die  $!;
4126         runcmd @git, qw(add -- debian/patches/series), $gipatch;
4127         commit_admin <<END
4128 Commit patch to update .gitignore
4129
4130 [dgit ($our_version) update-gitignore-quilt-fixup]
4131 END
4132     }
4133
4134     my $dgitview = git_rev_parse 'HEAD';
4135
4136     changedir '../../../..';
4137     # When we no longer need to support squeeze, use --create-reflog
4138     # instead of this:
4139     ensuredir ".git/logs/refs/dgit-intern";
4140     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
4141       or die $!;
4142
4143     my $oldcache = git_get_ref "refs/$splitbraincache";
4144     if ($oldcache eq $dgitview) {
4145         my $tree = cmdoutput qw(git rev-parse), "$dgitview:";
4146         # git update-ref doesn't always update, in this case.  *sigh*
4147         my $dummy = make_commit_text <<END;
4148 tree $tree
4149 parent $dgitview
4150 author Dgit <dgit\@example.com> 1000000000 +0000
4151 committer Dgit <dgit\@example.com> 1000000000 +0000
4152
4153 Dummy commit - do not use
4154 END
4155         runcmd @git, qw(update-ref -m), "dgit $our_version - dummy",
4156             "refs/$splitbraincache", $dummy;
4157     }
4158     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
4159         $dgitview;
4160
4161     progress "dgit view: created (commit id $dgitview)";
4162
4163     changedir '.git/dgit/unpack/work';
4164 }
4165
4166 sub quiltify ($$$$) {
4167     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
4168
4169     # Quilt patchification algorithm
4170     #
4171     # We search backwards through the history of the main tree's HEAD
4172     # (T) looking for a start commit S whose tree object is identical
4173     # to to the patch tip tree (ie the tree corresponding to the
4174     # current dpkg-committed patch series).  For these purposes
4175     # `identical' disregards anything in debian/ - this wrinkle is
4176     # necessary because dpkg-source treates debian/ specially.
4177     #
4178     # We can only traverse edges where at most one of the ancestors'
4179     # trees differs (in changes outside in debian/).  And we cannot
4180     # handle edges which change .pc/ or debian/patches.  To avoid
4181     # going down a rathole we avoid traversing edges which introduce
4182     # debian/rules or debian/control.  And we set a limit on the
4183     # number of edges we are willing to look at.
4184     #
4185     # If we succeed, we walk forwards again.  For each traversed edge
4186     # PC (with P parent, C child) (starting with P=S and ending with
4187     # C=T) to we do this:
4188     #  - git checkout C
4189     #  - dpkg-source --commit with a patch name and message derived from C
4190     # After traversing PT, we git commit the changes which
4191     # should be contained within debian/patches.
4192
4193     # The search for the path S..T is breadth-first.  We maintain a
4194     # todo list containing search nodes.  A search node identifies a
4195     # commit, and looks something like this:
4196     #  $p = {
4197     #      Commit => $git_commit_id,
4198     #      Child => $c,                          # or undef if P=T
4199     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
4200     #      Nontrivial => true iff $p..$c has relevant changes
4201     #  };
4202
4203     my @todo;
4204     my @nots;
4205     my $sref_S;
4206     my $max_work=100;
4207     my %considered; # saves being exponential on some weird graphs
4208
4209     my $t_sentinels = quiltify_tree_sentinelfiles $target;
4210
4211     my $not = sub {
4212         my ($search,$whynot) = @_;
4213         printdebug " search NOT $search->{Commit} $whynot\n";
4214         $search->{Whynot} = $whynot;
4215         push @nots, $search;
4216         no warnings qw(exiting);
4217         next;
4218     };
4219
4220     push @todo, {
4221         Commit => $target,
4222     };
4223
4224     while (@todo) {
4225         my $c = shift @todo;
4226         next if $considered{$c->{Commit}}++;
4227
4228         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
4229
4230         printdebug "quiltify investigate $c->{Commit}\n";
4231
4232         # are we done?
4233         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
4234             printdebug " search finished hooray!\n";
4235             $sref_S = $c;
4236             last;
4237         }
4238
4239         if ($quilt_mode eq 'nofix') {
4240             fail "quilt fixup required but quilt mode is \`nofix'\n".
4241                 "HEAD commit $c->{Commit} differs from tree implied by ".
4242                 " debian/patches (tree object $oldtiptree)";
4243         }
4244         if ($quilt_mode eq 'smash') {
4245             printdebug " search quitting smash\n";
4246             last;
4247         }
4248
4249         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
4250         $not->($c, "has $c_sentinels not $t_sentinels")
4251             if $c_sentinels ne $t_sentinels;
4252
4253         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
4254         $commitdata =~ m/\n\n/;
4255         $commitdata =~ $`;
4256         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
4257         @parents = map { { Commit => $_, Child => $c } } @parents;
4258
4259         $not->($c, "root commit") if !@parents;
4260
4261         foreach my $p (@parents) {
4262             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
4263         }
4264         my $ndiffers = grep { $_->{Nontrivial} } @parents;
4265         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
4266
4267         foreach my $p (@parents) {
4268             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
4269
4270             my @cmd= (@git, qw(diff-tree -r --name-only),
4271                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
4272             my $patchstackchange = cmdoutput @cmd;
4273             if (length $patchstackchange) {
4274                 $patchstackchange =~ s/\n/,/g;
4275                 $not->($p, "changed $patchstackchange");
4276             }
4277
4278             printdebug " search queue P=$p->{Commit} ",
4279                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
4280             push @todo, $p;
4281         }
4282     }
4283
4284     if (!$sref_S) {
4285         printdebug "quiltify want to smash\n";
4286
4287         my $abbrev = sub {
4288             my $x = $_[0]{Commit};
4289             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
4290             return $x;
4291         };
4292         my $reportnot = sub {
4293             my ($notp) = @_;
4294             my $s = $abbrev->($notp);
4295             my $c = $notp->{Child};
4296             $s .= "..".$abbrev->($c) if $c;
4297             $s .= ": ".$notp->{Whynot};
4298             return $s;
4299         };
4300         if ($quilt_mode eq 'linear') {
4301             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
4302             foreach my $notp (@nots) {
4303                 print STDERR "$us:  ", $reportnot->($notp), "\n";
4304             }
4305             print STDERR "$us: $_\n" foreach @$failsuggestion;
4306             fail "quilt fixup naive history linearisation failed.\n".
4307  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
4308         } elsif ($quilt_mode eq 'smash') {
4309         } elsif ($quilt_mode eq 'auto') {
4310             progress "quilt fixup cannot be linear, smashing...";
4311         } else {
4312             die "$quilt_mode ?";
4313         }
4314
4315         my $time = $ENV{'GIT_COMMITTER_DATE'} || time;
4316         $time =~ s/\s.*//; # trim timezone from GIT_COMMITTER_DATE
4317         my $ncommits = 3;
4318         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
4319
4320         quiltify_dpkg_commit "auto-$version-$target-$time",
4321             (getfield $clogp, 'Maintainer'),
4322             "Automatically generated patch ($clogp->{Version})\n".
4323             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
4324         return;
4325     }
4326
4327     progress "quiltify linearisation planning successful, executing...";
4328
4329     for (my $p = $sref_S;
4330          my $c = $p->{Child};
4331          $p = $p->{Child}) {
4332         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
4333         next unless $p->{Nontrivial};
4334
4335         my $cc = $c->{Commit};
4336
4337         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
4338         $commitdata =~ m/\n\n/ or die "$c ?";
4339         $commitdata = $`;
4340         my $msg = $'; #';
4341         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
4342         my $author = $1;
4343
4344         my $commitdate = cmdoutput
4345             @git, qw(log -n1 --pretty=format:%aD), $cc;
4346
4347         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
4348
4349         my $strip_nls = sub { $msg =~ s/\n+$//; $msg .= "\n"; };
4350         $strip_nls->();
4351
4352         my $title = $1;
4353         my $patchname;
4354         my $patchdir;
4355
4356         my $gbp_check_suitable = sub {
4357             $_ = shift;
4358             my ($what) = @_;
4359
4360             eval {
4361                 die "contains unexpected slashes\n" if m{//} || m{/$};
4362                 die "contains leading punctuation\n" if m{^\W} || m{/\W};
4363                 die "contains bad character(s)\n" if m{[^-a-z0-9_.+=~/]}i;
4364                 die "too long" if length > 200;
4365             };
4366             return $_ unless $@;
4367             print STDERR "quiltifying commit $cc:".
4368                 " ignoring/dropping Gbp-Pq $what: $@";
4369             return undef;
4370         };
4371
4372         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* name \s+ |
4373                            gbp-pq-name: \s* )
4374                        (\S+) \s* \n //ixm) {
4375             $patchname = $gbp_check_suitable->($1, 'Name');
4376         }
4377         if ($msg =~ s/^ (?: gbp(?:-pq)? : \s* topic \s+ |
4378                            gbp-pq-topic: \s* )
4379                        (\S+) \s* \n //ixm) {
4380             $patchdir = $gbp_check_suitable->($1, 'Topic');
4381         }
4382
4383         $strip_nls->();
4384
4385         if (!defined $patchname) {</