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