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