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