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