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