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