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