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