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