chiark / gitweb /
150c11539a46bee1a46c32d256a33a99061bdcf4
[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     # Ensures that lrref() is what is actually in the archive, one way
2140     # or another, according to us - ie this client's
2141     # appropritaely-updated archive view.  Also returns the commit id.
2142     # If there is nothing in the archive, leaves lrref alone and
2143     # returns undef.  git_fetch_us must have already been called.
2144     get_archive_dsc();
2145
2146     if ($dsc) {
2147         foreach my $field (@ourdscfield) {
2148             $dsc_hash = $dsc->{$field};
2149             last if defined $dsc_hash;
2150         }
2151         if (defined $dsc_hash) {
2152             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2153             $dsc_hash = $&;
2154             progress "last upload to archive specified git hash";
2155         } else {
2156             progress "last upload to archive has NO git hash";
2157         }
2158     } else {
2159         progress "no version available from the archive";
2160     }
2161
2162     # If the archive's .dsc has a Dgit field, there are three
2163     # relevant git commitids we need to choose between and/or merge
2164     # together:
2165     #   1. $dsc_hash: the Dgit field from the archive
2166     #   2. $lastpush_hash: the suite branch on the dgit git server
2167     #   3. $lastfetch_hash: our local tracking brach for the suite
2168     #
2169     # These may all be distinct and need not be in any fast forward
2170     # relationship:
2171     #
2172     # If the dsc was pushed to this suite, then the server suite
2173     # branch will have been updated; but it might have been pushed to
2174     # a different suite and copied by the archive.  Conversely a more
2175     # recent version may have been pushed with dgit but not appeared
2176     # in the archive (yet).
2177     #
2178     # $lastfetch_hash may be awkward because archive imports
2179     # (particularly, imports of Dgit-less .dscs) are performed only as
2180     # needed on individual clients, so different clients may perform a
2181     # different subset of them - and these imports are only made
2182     # public during push.  So $lastfetch_hash may represent a set of
2183     # imports different to a subsequent upload by a different dgit
2184     # client.
2185     #
2186     # Our approach is as follows:
2187     #
2188     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2189     # descendant of $dsc_hash, then it was pushed by a dgit user who
2190     # had based their work on $dsc_hash, so we should prefer it.
2191     # Otherwise, $dsc_hash was installed into this suite in the
2192     # archive other than by a dgit push, and (necessarily) after the
2193     # last dgit push into that suite (since a dgit push would have
2194     # been descended from the dgit server git branch); thus, in that
2195     # case, we prefer the archive's version (and produce a
2196     # pseudo-merge to overwrite the dgit server git branch).
2197     #
2198     # (If there is no Dgit field in the archive's .dsc then
2199     # generate_commit_from_dsc uses the version numbers to decide
2200     # whether the suite branch or the archive is newer.  If the suite
2201     # branch is newer it ignores the archive's .dsc; otherwise it
2202     # generates an import of the .dsc, and produces a pseudo-merge to
2203     # overwrite the suite branch with the archive contents.)
2204     #
2205     # The outcome of that part of the algorithm is the `public view',
2206     # and is same for all dgit clients: it does not depend on any
2207     # unpublished history in the local tracking branch.
2208     #
2209     # As between the public view and the local tracking branch: The
2210     # local tracking branch is only updated by dgit fetch, and
2211     # whenever dgit fetch runs it includes the public view in the
2212     # local tracking branch.  Therefore if the public view is not
2213     # descended from the local tracking branch, the local tracking
2214     # branch must contain history which was imported from the archive
2215     # but never pushed; and, its tip is now out of date.  So, we make
2216     # a pseudo-merge to overwrite the old imports and stitch the old
2217     # history in.
2218     #
2219     # Finally: we do not necessarily reify the public view (as
2220     # described above).  This is so that we do not end up stacking two
2221     # pseudo-merges.  So what we actually do is figure out the inputs
2222     # to any public view pseudo-merge and put them in @mergeinputs.
2223
2224     my @mergeinputs;
2225     # $mergeinputs[]{Commit}
2226     # $mergeinputs[]{Info}
2227     # $mergeinputs[0] is the one whose tree we use
2228     # @mergeinputs is in the order we use in the actual commit)
2229     #
2230     # Also:
2231     # $mergeinputs[]{Message} is a commit message to use
2232     # $mergeinputs[]{ReverseParents} if def specifies that parent
2233     #                                list should be in opposite order
2234     # Such an entry has no Commit or Info.  It applies only when found
2235     # in the last entry.  (This ugliness is to support making
2236     # identical imports to previous dgit versions.)
2237
2238     my $lastpush_hash = git_get_ref(lrfetchref());
2239     printdebug "previous reference hash=$lastpush_hash\n";
2240     $lastpush_mergeinput = $lastpush_hash && {
2241         Commit => $lastpush_hash,
2242         Info => "dgit suite branch on dgit git server",
2243     };
2244
2245     my $lastfetch_hash = git_get_ref(lrref());
2246     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2247     my $lastfetch_mergeinput = $lastfetch_hash && {
2248         Commit => $lastfetch_hash,
2249         Info => "dgit client's archive history view",
2250     };
2251
2252     my $dsc_mergeinput = $dsc_hash && {
2253         Commit => $dsc_hash,
2254         Info => "Dgit field in .dsc from archive",
2255     };
2256
2257     my $cwd = getcwd();
2258     my $del_lrfetchrefs = sub {
2259         changedir $cwd;
2260         my $gur;
2261         printdebug "del_lrfetchrefs...\n";
2262         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2263             my $objid = $lrfetchrefs_d{$fullrefname};
2264             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2265             if (!$gur) {
2266                 $gur ||= new IO::Handle;
2267                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2268             }
2269             printf $gur "delete %s %s\n", $fullrefname, $objid;
2270         }
2271         if ($gur) {
2272             close $gur or failedcmd "git update-ref delete lrfetchrefs";
2273         }
2274     };
2275
2276     if (defined $dsc_hash) {
2277         fail "missing remote git history even though dsc has hash -".
2278             " could not find ref ".rref()." at ".access_giturl()
2279             unless $lastpush_hash;
2280         ensure_we_have_orig();
2281         if ($dsc_hash eq $lastpush_hash) {
2282             @mergeinputs = $dsc_mergeinput
2283         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2284             print STDERR <<END or die $!;
2285
2286 Git commit in archive is behind the last version allegedly pushed/uploaded.
2287 Commit referred to by archive: $dsc_hash
2288 Last version pushed with dgit: $lastpush_hash
2289 $later_warning_msg
2290 END
2291             @mergeinputs = ($lastpush_mergeinput);
2292         } else {
2293             # Archive has .dsc which is not a descendant of the last dgit
2294             # push.  This can happen if the archive moves .dscs about.
2295             # Just follow its lead.
2296             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2297                 progress "archive .dsc names newer git commit";
2298                 @mergeinputs = ($dsc_mergeinput);
2299             } else {
2300                 progress "archive .dsc names other git commit, fixing up";
2301                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2302             }
2303         }
2304     } elsif ($dsc) {
2305         @mergeinputs = generate_commits_from_dsc();
2306         # We have just done an import.  Now, our import algorithm might
2307         # have been improved.  But even so we do not want to generate
2308         # a new different import of the same package.  So if the
2309         # version numbers are the same, just use our existing version.
2310         # If the version numbers are different, the archive has changed
2311         # (perhaps, rewound).
2312         if ($lastfetch_mergeinput &&
2313             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2314                               (mergeinfo_version $mergeinputs[0]) )) {
2315             @mergeinputs = ($lastfetch_mergeinput);
2316         }
2317     } elsif ($lastpush_hash) {
2318         # only in git, not in the archive yet
2319         @mergeinputs = ($lastpush_mergeinput);
2320         print STDERR <<END or die $!;
2321
2322 Package not found in the archive, but has allegedly been pushed using dgit.
2323 $later_warning_msg
2324 END
2325     } else {
2326         printdebug "nothing found!\n";
2327         if (defined $skew_warning_vsn) {
2328             print STDERR <<END or die $!;
2329
2330 Warning: relevant archive skew detected.
2331 Archive allegedly contains $skew_warning_vsn
2332 But we were not able to obtain any version from the archive or git.
2333
2334 END
2335         }
2336         unshift @end, $del_lrfetchrefs;
2337         return undef;
2338     }
2339
2340     if ($lastfetch_hash &&
2341         !grep {
2342             my $h = $_->{Commit};
2343             $h and is_fast_fwd($lastfetch_hash, $h);
2344             # If true, one of the existing parents of this commit
2345             # is a descendant of the $lastfetch_hash, so we'll
2346             # be ff from that automatically.
2347         } @mergeinputs
2348         ) {
2349         # Otherwise:
2350         push @mergeinputs, $lastfetch_mergeinput;
2351     }
2352
2353     printdebug "fetch mergeinfos:\n";
2354     foreach my $mi (@mergeinputs) {
2355         if ($mi->{Info}) {
2356             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2357         } else {
2358             printdebug sprintf " ReverseParents=%d Message=%s",
2359                 $mi->{ReverseParents}, $mi->{Message};
2360         }
2361     }
2362
2363     my $compat_info= pop @mergeinputs
2364         if $mergeinputs[$#mergeinputs]{Message};
2365
2366     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2367
2368     my $hash;
2369     if (@mergeinputs > 1) {
2370         # here we go, then:
2371         my $tree_commit = $mergeinputs[0]{Commit};
2372
2373         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2374         $tree =~ m/\n\n/;  $tree = $`;
2375         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2376         $tree = $1;
2377
2378         # We use the changelog author of the package in question the
2379         # author of this pseudo-merge.  This is (roughly) correct if
2380         # this commit is simply representing aa non-dgit upload.
2381         # (Roughly because it does not record sponsorship - but we
2382         # don't have sponsorship info because that's in the .changes,
2383         # which isn't in the archivw.)
2384         #
2385         # But, it might be that we are representing archive history
2386         # updates (including in-archive copies).  These are not really
2387         # the responsibility of the person who created the .dsc, but
2388         # there is no-one whose name we should better use.  (The
2389         # author of the .dsc-named commit is clearly worse.)
2390
2391         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2392         my $author = clogp_authline $useclogp;
2393         my $cversion = getfield $useclogp, 'Version';
2394
2395         my $mcf = ".git/dgit/mergecommit";
2396         open MC, ">", $mcf or die "$mcf $!";
2397         print MC <<END or die $!;
2398 tree $tree
2399 END
2400
2401         my @parents = grep { $_->{Commit} } @mergeinputs;
2402         @parents = reverse @parents if $compat_info->{ReverseParents};
2403         print MC <<END or die $! foreach @parents;
2404 parent $_->{Commit}
2405 END
2406
2407         print MC <<END or die $!;
2408 author $author
2409 committer $author
2410
2411 END
2412
2413         if (defined $compat_info->{Message}) {
2414             print MC $compat_info->{Message} or die $!;
2415         } else {
2416             print MC <<END or die $!;
2417 Record $package ($cversion) in archive suite $csuite
2418
2419 Record that
2420 END
2421             my $message_add_info = sub {
2422                 my ($mi) = (@_);
2423                 my $mversion = mergeinfo_version $mi;
2424                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2425                     or die $!;
2426             };
2427
2428             $message_add_info->($mergeinputs[0]);
2429             print MC <<END or die $!;
2430 should be treated as descended from
2431 END
2432             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2433         }
2434
2435         close MC or die $!;
2436         $hash = make_commit $mcf;
2437     } else {
2438         $hash = $mergeinputs[0]{Commit};
2439     }
2440     printdebug "fetch hash=$hash\n";
2441
2442     my $chkff = sub {
2443         my ($lasth, $what) = @_;
2444         return unless $lasth;
2445         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2446     };
2447
2448     $chkff->($lastpush_hash, 'dgit repo server tip (last push)');
2449     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2450
2451     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2452             'DGIT_ARCHIVE', $hash;
2453     cmdoutput @git, qw(log -n2), $hash;
2454     # ... gives git a chance to complain if our commit is malformed
2455
2456     if (defined $skew_warning_vsn) {
2457         mkpath '.git/dgit';
2458         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2459         my $gotclogp = commit_getclogp($hash);
2460         my $got_vsn = getfield $gotclogp, 'Version';
2461         printdebug "SKEW CHECK GOT $got_vsn\n";
2462         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2463             print STDERR <<END or die $!;
2464
2465 Warning: archive skew detected.  Using the available version:
2466 Archive allegedly contains    $skew_warning_vsn
2467 We were able to obtain only   $got_vsn
2468
2469 END
2470         }
2471     }
2472
2473     if ($lastfetch_hash ne $hash) {
2474         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2475         if (act_local()) {
2476             cmdoutput @upd_cmd;
2477         } else {
2478             dryrun_report @upd_cmd;
2479         }
2480     }
2481
2482     lrfetchref_used lrfetchref();
2483
2484     unshift @end, $del_lrfetchrefs;
2485     return $hash;
2486 }
2487
2488 sub set_local_git_config ($$) {
2489     my ($k, $v) = @_;
2490     runcmd @git, qw(config), $k, $v;
2491 }
2492
2493 sub setup_mergechangelogs (;$) {
2494     my ($always) = @_;
2495     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
2496
2497     my $driver = 'dpkg-mergechangelogs';
2498     my $cb = "merge.$driver";
2499     my $attrs = '.git/info/attributes';
2500     ensuredir '.git/info';
2501
2502     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
2503     if (!open ATTRS, "<", $attrs) {
2504         $!==ENOENT or die "$attrs: $!";
2505     } else {
2506         while (<ATTRS>) {
2507             chomp;
2508             next if m{^debian/changelog\s};
2509             print NATTRS $_, "\n" or die $!;
2510         }
2511         ATTRS->error and die $!;
2512         close ATTRS;
2513     }
2514     print NATTRS "debian/changelog merge=$driver\n" or die $!;
2515     close NATTRS;
2516
2517     set_local_git_config "$cb.name", 'debian/changelog merge driver';
2518     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
2519
2520     rename "$attrs.new", "$attrs" or die "$attrs: $!";
2521 }
2522
2523 sub setup_useremail (;$) {
2524     my ($always) = @_;
2525     return unless $always || access_cfg_bool(1, 'setup-useremail');
2526
2527     my $setup = sub {
2528         my ($k, $envvar) = @_;
2529         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
2530         return unless defined $v;
2531         set_local_git_config "user.$k", $v;
2532     };
2533
2534     $setup->('email', 'DEBEMAIL');
2535     $setup->('name', 'DEBFULLNAME');
2536 }
2537
2538 sub setup_new_tree () {
2539     setup_mergechangelogs();
2540     setup_useremail();
2541 }
2542
2543 sub clone ($) {
2544     my ($dstdir) = @_;
2545     canonicalise_suite();
2546     badusage "dry run makes no sense with clone" unless act_local();
2547     my $hasgit = check_for_git();
2548     mkdir $dstdir or fail "create \`$dstdir': $!";
2549     changedir $dstdir;
2550     runcmd @git, qw(init -q);
2551     my $giturl = access_giturl(1);
2552     if (defined $giturl) {
2553         open H, "> .git/HEAD" or die $!;
2554         print H "ref: ".lref()."\n" or die $!;
2555         close H or die $!;
2556         runcmd @git, qw(remote add), 'origin', $giturl;
2557     }
2558     if ($hasgit) {
2559         progress "fetching existing git history";
2560         git_fetch_us();
2561         runcmd_ordryrun_local @git, qw(fetch origin);
2562     } else {
2563         progress "starting new git history";
2564     }
2565     fetch_from_archive() or no_such_package;
2566     my $vcsgiturl = $dsc->{'Vcs-Git'};
2567     if (length $vcsgiturl) {
2568         $vcsgiturl =~ s/\s+-b\s+\S+//g;
2569         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
2570     }
2571     setup_new_tree();
2572     runcmd @git, qw(reset --hard), lrref();
2573     printdone "ready for work in $dstdir";
2574 }
2575
2576 sub fetch () {
2577     if (check_for_git()) {
2578         git_fetch_us();
2579     }
2580     fetch_from_archive() or no_such_package();
2581     printdone "fetched into ".lrref();
2582 }
2583
2584 sub pull () {
2585     fetch();
2586     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
2587         lrref();
2588     printdone "fetched to ".lrref()." and merged into HEAD";
2589 }
2590
2591 sub check_not_dirty () {
2592     foreach my $f (qw(local-options local-patch-header)) {
2593         if (stat_exists "debian/source/$f") {
2594             fail "git tree contains debian/source/$f";
2595         }
2596     }
2597
2598     return if $ignoredirty;
2599
2600     my @cmd = (@git, qw(diff --quiet HEAD));
2601     debugcmd "+",@cmd;
2602     $!=0; $?=-1; system @cmd;
2603     return if !$?;
2604     if ($?==256) {
2605         fail "working tree is dirty (does not match HEAD)";
2606     } else {
2607         failedcmd @cmd;
2608     }
2609 }
2610
2611 sub commit_admin ($) {
2612     my ($m) = @_;
2613     progress "$m";
2614     runcmd_ordryrun_local @git, qw(commit -m), $m;
2615 }
2616
2617 sub commit_quilty_patch () {
2618     my $output = cmdoutput @git, qw(status --porcelain);
2619     my %adds;
2620     foreach my $l (split /\n/, $output) {
2621         next unless $l =~ m/\S/;
2622         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
2623             $adds{$1}++;
2624         }
2625     }
2626     delete $adds{'.pc'}; # if there wasn't one before, don't add it
2627     if (!%adds) {
2628         progress "nothing quilty to commit, ok.";
2629         return;
2630     }
2631     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
2632     runcmd_ordryrun_local @git, qw(add -f), @adds;
2633     commit_admin <<END
2634 Commit Debian 3.0 (quilt) metadata
2635
2636 [dgit ($our_version) quilt-fixup]
2637 END
2638 }
2639
2640 sub get_source_format () {
2641     my %options;
2642     if (open F, "debian/source/options") {
2643         while (<F>) {
2644             next if m/^\s*\#/;
2645             next unless m/\S/;
2646             s/\s+$//; # ignore missing final newline
2647             if (m/\s*\#\s*/) {
2648                 my ($k, $v) = ($`, $'); #');
2649                 $v =~ s/^"(.*)"$/$1/;
2650                 $options{$k} = $v;
2651             } else {
2652                 $options{$_} = 1;
2653             }
2654         }
2655         F->error and die $!;
2656         close F;
2657     } else {
2658         die $! unless $!==&ENOENT;
2659     }
2660
2661     if (!open F, "debian/source/format") {
2662         die $! unless $!==&ENOENT;
2663         return '';
2664     }
2665     $_ = <F>;
2666     F->error and die $!;
2667     chomp;
2668     return ($_, \%options);
2669 }
2670
2671 sub madformat_wantfixup ($) {
2672     my ($format) = @_;
2673     return 0 unless $format eq '3.0 (quilt)';
2674     our $quilt_mode_warned;
2675     if ($quilt_mode eq 'nocheck') {
2676         progress "Not doing any fixup of \`$format' due to".
2677             " ----no-quilt-fixup or --quilt=nocheck"
2678             unless $quilt_mode_warned++;
2679         return 0;
2680     }
2681     progress "Format \`$format', need to check/update patch stack"
2682         unless $quilt_mode_warned++;
2683     return 1;
2684 }
2685
2686 # An "infopair" is a tuple [ $thing, $what ]
2687 # (often $thing is a commit hash; $what is a description)
2688
2689 sub infopair_cond_equal ($$) {
2690     my ($x,$y) = @_;
2691     $x->[0] eq $y->[0] or fail <<END;
2692 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
2693 END
2694 };
2695
2696 sub infopair_lrf_tag_lookup ($$) {
2697     my ($tagnames, $what) = @_;
2698     # $tagname may be an array ref
2699     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
2700     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
2701     foreach my $tagname (@tagnames) {
2702         my $lrefname = lrfetchrefs."/tags/$tagname";
2703         my $tagobj = $lrfetchrefs_f{$lrefname};
2704         next unless defined $tagobj;
2705         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
2706         return [ git_rev_parse($tagobj), $what ];
2707     }
2708     fail @tagnames==1 ? <<END : <<END;
2709 Wanted tag $what (@tagnames) on dgit server, but not found
2710 END
2711 Wanted tag $what (one of: @tagnames) on dgit server, but not found
2712 END
2713 }
2714
2715 sub infopair_cond_ff ($$) {
2716     my ($anc,$desc) = @_;
2717     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
2718 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
2719 END
2720 };
2721
2722 sub pseudomerge_version_check ($$) {
2723     my ($clogp, $archive_hash) = @_;
2724
2725     my $arch_clogp = commit_getclogp $archive_hash;
2726     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
2727                      'version currently in archive' ];
2728     if (defined $overwrite_version) {
2729         if (length $overwrite_version) {
2730             infopair_cond_equal([ $overwrite_version,
2731                                   '--overwrite= version' ],
2732                                 $i_arch_v);
2733         } else {
2734             my $v = $i_arch_v->[0];
2735             progress "Checking package changelog for archive version $v ...";
2736             eval {
2737                 my @xa = ("-f$v", "-t$v");
2738                 my $vclogp = parsechangelog @xa;
2739                 my $cv = [ (getfield $vclogp, 'Version'),
2740                            "Version field from dpkg-parsechangelog @xa" ];
2741                 infopair_cond_equal($i_arch_v, $cv);
2742             };
2743             if ($@) {
2744                 $@ =~ s/^dgit: //gm;
2745                 fail "$@".
2746                     "Perhaps debian/changelog does not mention $v ?";
2747             }
2748         }
2749     }
2750     
2751     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
2752     return $i_arch_v;
2753 }
2754
2755 sub pseudomerge_make_commit ($$$$ $$) {
2756     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
2757         $msg_cmd, $msg_msg) = @_;
2758     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
2759
2760     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
2761     my $authline = clogp_authline $clogp;
2762
2763     chomp $msg_msg;
2764     $msg_cmd .=
2765         !defined $overwrite_version ? ""
2766         : !length  $overwrite_version ? " --overwrite"
2767         : " --overwrite=".$overwrite_version;
2768
2769     mkpath '.git/dgit';
2770     my $pmf = ".git/dgit/pseudomerge";
2771     open MC, ">", $pmf or die "$pmf $!";
2772     print MC <<END or die $!;
2773 tree $tree
2774 parent $dgitview
2775 parent $archive_hash
2776 author $authline
2777 commiter $authline
2778
2779 $msg_msg
2780
2781 [$msg_cmd]
2782 END
2783     close MC or die $!;
2784
2785     return make_commit($pmf);
2786 }
2787
2788 sub splitbrain_pseudomerge ($$$$) {
2789     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
2790     # => $merged_dgitview
2791     printdebug "splitbrain_pseudomerge...\n";
2792     #
2793     #     We:      debian/PREVIOUS    HEAD($maintview)
2794     # expect:          o ----------------- o
2795     #                    \                   \
2796     #                     o                   o
2797     #                 a/d/PREVIOUS        $dgitview
2798     #                $archive_hash              \
2799     #  If so,                \                   \
2800     #  we do:                 `------------------ o
2801     #   this:                                   $dgitview'
2802     #
2803
2804     printdebug "splitbrain_pseudomerge...\n";
2805
2806     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2807
2808     return $dgitview unless defined $archive_hash;
2809
2810     if (!defined $overwrite_version) {
2811         progress "Checking that HEAD inciudes all changes in archive...";
2812     }
2813
2814     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
2815
2816     my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_basedistro;
2817     my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
2818     my $t_dgit = debiantag_new $i_arch_v->[0], access_basedistro;
2819     my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
2820     my $i_archive = [ $archive_hash, "current archive contents" ];
2821
2822     printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
2823
2824     infopair_cond_equal($i_dgit, $i_archive);
2825     infopair_cond_ff($i_dep14, $i_dgit);
2826     $overwrite_version // infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
2827
2828     my $r = pseudomerge_make_commit
2829         $clogp, $dgitview, $archive_hash, $i_arch_v,
2830         "dgit --quilt=$quilt_mode",
2831         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
2832 Declare fast forward from $overwrite_version
2833 END_OVERWR
2834 Make fast forward from $i_arch_v->[0]
2835 END_MAKEFF
2836
2837     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
2838     return $r;
2839 }       
2840
2841 sub plain_overwrite_pseudomerge ($$$) {
2842     my ($clogp, $head, $archive_hash) = @_;
2843
2844     printdebug "plain_overwrite_pseudomerge...";
2845
2846     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
2847
2848     my @tagformats = access_cfg_tagformats();
2849     my @t_overwr =
2850         map { $_->($i_arch_v->[0], access_basedistro) }
2851         (grep { m/^(?:old|hist)$/ } @tagformats)
2852         ? \&debiantags : \&debiantag_new;
2853     my $i_overwr = infopair_lrf_tag_lookup \@t_overwr, "previous version tag";
2854     my $i_archive = [ $archive_hash, "current archive contents" ];
2855
2856     infopair_cond_equal($i_overwr, $i_archive);
2857
2858     return $head if is_fast_fwd $archive_hash, $head;
2859
2860     my $m = "Declare fast forward from $i_arch_v->[0]";
2861
2862     my $r = pseudomerge_make_commit
2863         $clogp, $head, $archive_hash, $i_arch_v,
2864         "dgit", $m;
2865
2866     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
2867
2868     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
2869     return $r;
2870 }
2871
2872 sub push_parse_changelog ($) {
2873     my ($clogpfn) = @_;
2874
2875     my $clogp = Dpkg::Control::Hash->new();
2876     $clogp->load($clogpfn) or die;
2877
2878     $package = getfield $clogp, 'Source';
2879     my $cversion = getfield $clogp, 'Version';
2880     my $tag = debiantag($cversion, access_basedistro);
2881     runcmd @git, qw(check-ref-format), $tag;
2882
2883     my $dscfn = dscfn($cversion);
2884
2885     return ($clogp, $cversion, $dscfn);
2886 }
2887
2888 sub push_parse_dsc ($$$) {
2889     my ($dscfn,$dscfnwhat, $cversion) = @_;
2890     $dsc = parsecontrol($dscfn,$dscfnwhat);
2891     my $dversion = getfield $dsc, 'Version';
2892     my $dscpackage = getfield $dsc, 'Source';
2893     ($dscpackage eq $package && $dversion eq $cversion) or
2894         fail "$dscfn is for $dscpackage $dversion".
2895             " but debian/changelog is for $package $cversion";
2896 }
2897
2898 sub push_tagwants ($$$$) {
2899     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
2900     my @tagwants;
2901     push @tagwants, {
2902         TagFn => \&debiantag,
2903         Objid => $dgithead,
2904         TfSuffix => '',
2905         View => 'dgit',
2906     };
2907     if (defined $maintviewhead) {
2908         push @tagwants, {
2909             TagFn => \&debiantag_maintview,
2910             Objid => $maintviewhead,
2911             TfSuffix => '-maintview',
2912             View => 'maint',
2913         };
2914     }
2915     foreach my $tw (@tagwants) {
2916         $tw->{Tag} = $tw->{TagFn}($cversion, access_basedistro);
2917         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
2918     }
2919     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
2920     return @tagwants;
2921 }
2922
2923 sub push_mktags ($$ $$ $) {
2924     my ($clogp,$dscfn,
2925         $changesfile,$changesfilewhat,
2926         $tagwants) = @_;
2927
2928     die unless $tagwants->[0]{View} eq 'dgit';
2929
2930     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
2931     $dsc->save("$dscfn.tmp") or die $!;
2932
2933     my $changes = parsecontrol($changesfile,$changesfilewhat);
2934     foreach my $field (qw(Source Distribution Version)) {
2935         $changes->{$field} eq $clogp->{$field} or
2936             fail "changes field $field \`$changes->{$field}'".
2937                 " does not match changelog \`$clogp->{$field}'";
2938     }
2939
2940     my $cversion = getfield $clogp, 'Version';
2941     my $clogsuite = getfield $clogp, 'Distribution';
2942
2943     # We make the git tag by hand because (a) that makes it easier
2944     # to control the "tagger" (b) we can do remote signing
2945     my $authline = clogp_authline $clogp;
2946     my $delibs = join(" ", "",@deliberatelies);
2947     my $declaredistro = access_basedistro();
2948
2949     my $mktag = sub {
2950         my ($tw) = @_;
2951         my $tfn = $tw->{Tfn};
2952         my $head = $tw->{Objid};
2953         my $tag = $tw->{Tag};
2954
2955         open TO, '>', $tfn->('.tmp') or die $!;
2956         print TO <<END or die $!;
2957 object $head
2958 type commit
2959 tag $tag
2960 tagger $authline
2961
2962 END
2963         if ($tw->{View} eq 'dgit') {
2964             print TO <<END or die $!;
2965 $package release $cversion for $clogsuite ($csuite) [dgit]
2966 [dgit distro=$declaredistro$delibs]
2967 END
2968             foreach my $ref (sort keys %previously) {
2969                 print TO <<END or die $!;
2970 [dgit previously:$ref=$previously{$ref}]
2971 END
2972             }
2973         } elsif ($tw->{View} eq 'maint') {
2974             print TO <<END or die $!;
2975 $package release $cversion for $clogsuite ($csuite)
2976 (maintainer view tag generated by dgit --quilt=$quilt_mode)
2977 END
2978         } else {
2979             die Dumper($tw)."?";
2980         }
2981
2982         close TO or die $!;
2983
2984         my $tagobjfn = $tfn->('.tmp');
2985         if ($sign) {
2986             if (!defined $keyid) {
2987                 $keyid = access_cfg('keyid','RETURN-UNDEF');
2988             }
2989             if (!defined $keyid) {
2990                 $keyid = getfield $clogp, 'Maintainer';
2991             }
2992             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
2993             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
2994             push @sign_cmd, qw(-u),$keyid if defined $keyid;
2995             push @sign_cmd, $tfn->('.tmp');
2996             runcmd_ordryrun @sign_cmd;
2997             if (act_scary()) {
2998                 $tagobjfn = $tfn->('.signed.tmp');
2999                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3000                     $tfn->('.tmp'), $tfn->('.tmp.asc');
3001             }
3002         }
3003         return $tagobjfn;
3004     };
3005
3006     my @r = map { $mktag->($_); } @$tagwants;
3007     return @r;
3008 }
3009
3010 sub sign_changes ($) {
3011     my ($changesfile) = @_;
3012     if ($sign) {
3013         my @debsign_cmd = @debsign;
3014         push @debsign_cmd, "-k$keyid" if defined $keyid;
3015         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3016         push @debsign_cmd, $changesfile;
3017         runcmd_ordryrun @debsign_cmd;
3018     }
3019 }
3020
3021 sub dopush () {
3022     printdebug "actually entering push\n";
3023
3024     supplementary_message(<<'END');
3025 Push failed, while checking state of the archive.
3026 You can retry the push, after fixing the problem, if you like.
3027 END
3028     if (check_for_git()) {
3029         git_fetch_us();
3030     }
3031     my $archive_hash = fetch_from_archive();
3032     if (!$archive_hash) {
3033         $new_package or
3034             fail "package appears to be new in this suite;".
3035                 " if this is intentional, use --new";
3036     }
3037
3038     supplementary_message(<<'END');
3039 Push failed, while preparing your push.
3040 You can retry the push, after fixing the problem, if you like.
3041 END
3042
3043     need_tagformat 'new', "quilt mode $quilt_mode"
3044         if quiltmode_splitbrain;
3045
3046     prep_ud();
3047
3048     access_giturl(); # check that success is vaguely likely
3049     select_tagformat();
3050
3051     my $clogpfn = ".git/dgit/changelog.822.tmp";
3052     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3053
3054     responder_send_file('parsed-changelog', $clogpfn);
3055
3056     my ($clogp, $cversion, $dscfn) =
3057         push_parse_changelog("$clogpfn");
3058
3059     my $dscpath = "$buildproductsdir/$dscfn";
3060     stat_exists $dscpath or
3061         fail "looked for .dsc $dscfn, but $!;".
3062             " maybe you forgot to build";
3063
3064     responder_send_file('dsc', $dscpath);
3065
3066     push_parse_dsc($dscpath, $dscfn, $cversion);
3067
3068     my $format = getfield $dsc, 'Format';
3069     printdebug "format $format\n";
3070
3071     my $actualhead = git_rev_parse('HEAD');
3072     my $dgithead = $actualhead;
3073     my $maintviewhead = undef;
3074
3075     if (madformat_wantfixup($format)) {
3076         # user might have not used dgit build, so maybe do this now:
3077         if (quiltmode_splitbrain()) {
3078             my $upstreamversion = $clogp->{Version};
3079             $upstreamversion =~ s/-[^-]*$//;
3080             changedir $ud;
3081             quilt_make_fake_dsc($upstreamversion);
3082             my ($dgitview, $cachekey) =
3083                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3084             $dgitview or fail
3085  "--quilt=$quilt_mode but no cached dgit view:
3086  perhaps tree changed since dgit build[-source] ?";
3087             $split_brain = 1;
3088             $dgithead = splitbrain_pseudomerge($clogp,
3089                                                $actualhead, $dgitview,
3090                                                $archive_hash);
3091             $maintviewhead = $actualhead;
3092             changedir '../../../..';
3093             prep_ud(); # so _only_subdir() works, below
3094         } else {
3095             commit_quilty_patch();
3096         }
3097     }
3098
3099     if (defined $overwrite_version && !defined $maintviewhead) {
3100         $dgithead = plain_overwrite_pseudomerge($clogp,
3101                                                 $dgithead,
3102                                                 $archive_hash);
3103     }
3104
3105     check_not_dirty();
3106
3107     my $forceflag = '';
3108     if ($archive_hash) {
3109         if (is_fast_fwd($archive_hash, $dgithead)) {
3110             # ok
3111         } elsif (deliberately_not_fast_forward) {
3112             $forceflag = '+';
3113         } else {
3114             fail "dgit push: HEAD is not a descendant".
3115                 " of the archive's version.\n".
3116                 "To overwrite the archive's contents,".
3117                 " pass --overwrite[=VERSION].\n".
3118                 "To rewind history, if permitted by the archive,".
3119                 " use --deliberately-not-fast-forward.";
3120         }
3121     }
3122
3123     changedir $ud;
3124     progress "checking that $dscfn corresponds to HEAD";
3125     runcmd qw(dpkg-source -x --),
3126         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3127     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3128     check_for_vendor_patches() if madformat($dsc->{format});
3129     changedir '../../../..';
3130     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
3131     my @diffcmd = (@git, qw(diff), $diffopt, $tree, $dgithead);
3132     debugcmd "+",@diffcmd;
3133     $!=0; $?=-1;
3134     my $r = system @diffcmd;
3135     if ($r) {
3136         if ($r==256) {
3137             fail "$dscfn specifies a different tree to your HEAD commit;".
3138                 " perhaps you forgot to build".
3139                 ($diffopt eq '--exit-code' ? "" :
3140                  " (run with -D to see full diff output)");
3141         } else {
3142             failedcmd @diffcmd;
3143         }
3144     }
3145     if (!$changesfile) {
3146         my $pat = changespat $cversion;
3147         my @cs = glob "$buildproductsdir/$pat";
3148         fail "failed to find unique changes file".
3149             " (looked for $pat in $buildproductsdir);".
3150             " perhaps you need to use dgit -C"
3151             unless @cs==1;
3152         ($changesfile) = @cs;
3153     } else {
3154         $changesfile = "$buildproductsdir/$changesfile";
3155     }
3156
3157     # Checks complete, we're going to try and go ahead:
3158
3159     responder_send_file('changes',$changesfile);
3160     responder_send_command("param head $dgithead");
3161     responder_send_command("param csuite $csuite");
3162     responder_send_command("param tagformat $tagformat");
3163     if (defined $maintviewhead) {
3164         die unless ($protovsn//4) >= 4;
3165         responder_send_command("param maint-view $maintviewhead");
3166     }
3167
3168     if (deliberately_not_fast_forward) {
3169         git_for_each_ref(lrfetchrefs, sub {
3170             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
3171             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
3172             responder_send_command("previously $rrefname=$objid");
3173             $previously{$rrefname} = $objid;
3174         });
3175     }
3176
3177     my @tagwants = push_tagwants($cversion, $dgithead, $maintviewhead,
3178                                  ".git/dgit/tag");
3179     my @tagobjfns;
3180
3181     supplementary_message(<<'END');
3182 Push failed, while signing the tag.
3183 You can retry the push, after fixing the problem, if you like.
3184 END
3185     # If we manage to sign but fail to record it anywhere, it's fine.
3186     if ($we_are_responder) {
3187         @tagobjfns = map { $_->{Tfn}('.signed-tmp') } @tagwants;
3188         responder_receive_files('signed-tag', @tagobjfns);
3189     } else {
3190         @tagobjfns = push_mktags($clogp,$dscpath,
3191                               $changesfile,$changesfile,
3192                               \@tagwants);
3193     }
3194     supplementary_message(<<'END');
3195 Push failed, *after* signing the tag.
3196 If you want to try again, you should use a new version number.
3197 END
3198
3199     pairwise { $a->{TagObjFn} = $b } @tagwants, @tagobjfns;
3200
3201     foreach my $tw (@tagwants) {
3202         my $tag = $tw->{Tag};
3203         my $tagobjfn = $tw->{TagObjFn};
3204         my $tag_obj_hash =
3205             cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
3206         runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
3207         runcmd_ordryrun_local
3208             @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
3209     }
3210
3211     supplementary_message(<<'END');
3212 Push failed, while updating the remote git repository - see messages above.
3213 If you want to try again, you should use a new version number.
3214 END
3215     if (!check_for_git()) {
3216         create_remote_git_repo();
3217     }
3218
3219     my @pushrefs = $forceflag.$dgithead.":".rrref();
3220     foreach my $tw (@tagwants) {
3221         push @pushrefs, $forceflag."refs/tags/$tw->{Tag}";
3222     }
3223
3224     runcmd_ordryrun @git, qw(push),access_giturl(), @pushrefs;
3225     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), $dgithead;
3226
3227     supplementary_message(<<'END');
3228 Push failed, after updating the remote git repository.
3229 If you want to try again, you must use a new version number.
3230 END
3231     if ($we_are_responder) {
3232         my $dryrunsuffix = act_local() ? "" : ".tmp";
3233         responder_receive_files('signed-dsc-changes',
3234                                 "$dscpath$dryrunsuffix",
3235                                 "$changesfile$dryrunsuffix");
3236     } else {
3237         if (act_local()) {
3238             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
3239         } else {
3240             progress "[new .dsc left in $dscpath.tmp]";
3241         }
3242         sign_changes $changesfile;
3243     }
3244
3245     supplementary_message(<<END);
3246 Push failed, while uploading package(s) to the archive server.
3247 You can retry the upload of exactly these same files with dput of:
3248   $changesfile
3249 If that .changes file is broken, you will need to use a new version
3250 number for your next attempt at the upload.
3251 END
3252     my $host = access_cfg('upload-host','RETURN-UNDEF');
3253     my @hostarg = defined($host) ? ($host,) : ();
3254     runcmd_ordryrun @dput, @hostarg, $changesfile;
3255     printdone "pushed and uploaded $cversion";
3256
3257     supplementary_message('');
3258     responder_send_command("complete");
3259 }
3260
3261 sub cmd_clone {
3262     parseopts();
3263     notpushing();
3264     my $dstdir;
3265     badusage "-p is not allowed with clone; specify as argument instead"
3266         if defined $package;
3267     if (@ARGV==1) {
3268         ($package) = @ARGV;
3269     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
3270         ($package,$isuite) = @ARGV;
3271     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
3272         ($package,$dstdir) = @ARGV;
3273     } elsif (@ARGV==3) {
3274         ($package,$isuite,$dstdir) = @ARGV;
3275     } else {
3276         badusage "incorrect arguments to dgit clone";
3277     }
3278     $dstdir ||= "$package";
3279
3280     if (stat_exists $dstdir) {
3281         fail "$dstdir already exists";
3282     }
3283
3284     my $cwd_remove;
3285     if ($rmonerror && !$dryrun_level) {
3286         $cwd_remove= getcwd();
3287         unshift @end, sub { 
3288             return unless defined $cwd_remove;
3289             if (!chdir "$cwd_remove") {
3290                 return if $!==&ENOENT;
3291                 die "chdir $cwd_remove: $!";
3292             }
3293             if (stat $dstdir) {
3294                 rmtree($dstdir) or die "remove $dstdir: $!\n";
3295             } elsif (!grep { $! == $_ }
3296                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
3297             } else {
3298                 print STDERR "check whether to remove $dstdir: $!\n";
3299             }
3300         };
3301     }
3302
3303     clone($dstdir);
3304     $cwd_remove = undef;
3305 }
3306
3307 sub branchsuite () {
3308     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
3309     if ($branch =~ m#$lbranch_re#o) {
3310         return $1;
3311     } else {
3312         return undef;
3313     }
3314 }
3315
3316 sub fetchpullargs () {
3317     notpushing();
3318     if (!defined $package) {
3319         my $sourcep = parsecontrol('debian/control','debian/control');
3320         $package = getfield $sourcep, 'Source';
3321     }
3322     if (@ARGV==0) {
3323 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
3324         if (!$isuite) {
3325             my $clogp = parsechangelog();
3326             $isuite = getfield $clogp, 'Distribution';
3327         }
3328         canonicalise_suite();
3329         progress "fetching from suite $csuite";
3330     } elsif (@ARGV==1) {
3331         ($isuite) = @ARGV;
3332         canonicalise_suite();
3333     } else {
3334         badusage "incorrect arguments to dgit fetch or dgit pull";
3335     }
3336 }
3337
3338 sub cmd_fetch {
3339     parseopts();
3340     fetchpullargs();
3341     fetch();
3342 }
3343
3344 sub cmd_pull {
3345     parseopts();
3346     fetchpullargs();
3347     pull();
3348 }
3349
3350 sub cmd_push {
3351     parseopts();
3352     pushing();
3353     badusage "-p is not allowed with dgit push" if defined $package;
3354     check_not_dirty();
3355     my $clogp = parsechangelog();
3356     $package = getfield $clogp, 'Source';
3357     my $specsuite;
3358     if (@ARGV==0) {
3359     } elsif (@ARGV==1) {
3360         ($specsuite) = (@ARGV);
3361     } else {
3362         badusage "incorrect arguments to dgit push";
3363     }
3364     $isuite = getfield $clogp, 'Distribution';
3365     if ($new_package) {
3366         local ($package) = $existing_package; # this is a hack
3367         canonicalise_suite();
3368     } else {
3369         canonicalise_suite();
3370     }
3371     if (defined $specsuite &&
3372         $specsuite ne $isuite &&
3373         $specsuite ne $csuite) {
3374             fail "dgit push: changelog specifies $isuite ($csuite)".
3375                 " but command line specifies $specsuite";
3376     }
3377     dopush();
3378 }
3379
3380 #---------- remote commands' implementation ----------
3381
3382 sub cmd_remote_push_build_host {
3383     my ($nrargs) = shift @ARGV;
3384     my (@rargs) = @ARGV[0..$nrargs-1];
3385     @ARGV = @ARGV[$nrargs..$#ARGV];
3386     die unless @rargs;
3387     my ($dir,$vsnwant) = @rargs;
3388     # vsnwant is a comma-separated list; we report which we have
3389     # chosen in our ready response (so other end can tell if they
3390     # offered several)
3391     $debugprefix = ' ';
3392     $we_are_responder = 1;
3393     $us .= " (build host)";
3394
3395     pushing();
3396
3397     open PI, "<&STDIN" or die $!;
3398     open STDIN, "/dev/null" or die $!;
3399     open PO, ">&STDOUT" or die $!;
3400     autoflush PO 1;
3401     open STDOUT, ">&STDERR" or die $!;
3402     autoflush STDOUT 1;
3403
3404     $vsnwant //= 1;
3405     ($protovsn) = grep {
3406         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
3407     } @rpushprotovsn_support;
3408
3409     fail "build host has dgit rpush protocol versions ".
3410         (join ",", @rpushprotovsn_support).
3411         " but invocation host has $vsnwant"
3412         unless defined $protovsn;
3413
3414     responder_send_command("dgit-remote-push-ready $protovsn");
3415     rpush_handle_protovsn_bothends();
3416     changedir $dir;
3417     &cmd_push;
3418 }
3419
3420 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
3421 # ... for compatibility with proto vsn.1 dgit (just so that user gets
3422 #     a good error message)
3423
3424 sub rpush_handle_protovsn_bothends () {
3425     if ($protovsn < 4) {
3426         need_tagformat 'old', "rpush negotiated protocol $protovsn";
3427     }
3428     select_tagformat();
3429 }
3430
3431 our $i_tmp;
3432
3433 sub i_cleanup {
3434     local ($@, $?);
3435     my $report = i_child_report();
3436     if (defined $report) {
3437         printdebug "($report)\n";
3438     } elsif ($i_child_pid) {
3439         printdebug "(killing build host child $i_child_pid)\n";
3440         kill 15, $i_child_pid;
3441     }
3442     if (defined $i_tmp && !defined $initiator_tempdir) {
3443         changedir "/";
3444         eval { rmtree $i_tmp; };
3445     }
3446 }
3447
3448 END { i_cleanup(); }
3449
3450 sub i_method {
3451     my ($base,$selector,@args) = @_;
3452     $selector =~ s/\-/_/g;
3453     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
3454 }
3455
3456 sub cmd_rpush {
3457     pushing();
3458     my $host = nextarg;
3459     my $dir;
3460     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
3461         $host = $1;
3462         $dir = $'; #';
3463     } else {
3464         $dir = nextarg;
3465     }
3466     $dir =~ s{^-}{./-};
3467     my @rargs = ($dir);
3468     push @rargs, join ",", @rpushprotovsn_support;
3469     my @rdgit;
3470     push @rdgit, @dgit;
3471     push @rdgit, @ropts;
3472     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
3473     push @rdgit, @ARGV;
3474     my @cmd = (@ssh, $host, shellquote @rdgit);
3475     debugcmd "+",@cmd;
3476
3477     if (defined $initiator_tempdir) {
3478         rmtree $initiator_tempdir;
3479         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
3480         $i_tmp = $initiator_tempdir;
3481     } else {
3482         $i_tmp = tempdir();
3483     }
3484     $i_child_pid = open2(\*RO, \*RI, @cmd);
3485     changedir $i_tmp;
3486     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
3487     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
3488     $supplementary_message = '' unless $protovsn >= 3;
3489
3490     fail "rpush negotiated protocol version $protovsn".
3491         " which does not support quilt mode $quilt_mode"
3492         if quiltmode_splitbrain;
3493
3494     rpush_handle_protovsn_bothends();
3495     for (;;) {
3496         my ($icmd,$iargs) = initiator_expect {
3497             m/^(\S+)(?: (.*))?$/;
3498             ($1,$2);
3499         };
3500         i_method "i_resp", $icmd, $iargs;
3501     }
3502 }
3503
3504 sub i_resp_progress ($) {
3505     my ($rhs) = @_;
3506     my $msg = protocol_read_bytes \*RO, $rhs;
3507     progress $msg;
3508 }
3509
3510 sub i_resp_supplementary_message ($) {
3511     my ($rhs) = @_;
3512     $supplementary_message = protocol_read_bytes \*RO, $rhs;
3513 }
3514
3515 sub i_resp_complete {
3516     my $pid = $i_child_pid;
3517     $i_child_pid = undef; # prevents killing some other process with same pid
3518     printdebug "waiting for build host child $pid...\n";
3519     my $got = waitpid $pid, 0;
3520     die $! unless $got == $pid;
3521     die "build host child failed $?" if $?;
3522
3523     i_cleanup();
3524     printdebug "all done\n";
3525     exit 0;
3526 }
3527
3528 sub i_resp_file ($) {
3529     my ($keyword) = @_;
3530     my $localname = i_method "i_localname", $keyword;
3531     my $localpath = "$i_tmp/$localname";
3532     stat_exists $localpath and
3533         badproto \*RO, "file $keyword ($localpath) twice";
3534     protocol_receive_file \*RO, $localpath;
3535     i_method "i_file", $keyword;
3536 }
3537
3538 our %i_param;
3539
3540 sub i_resp_param ($) {
3541     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
3542     $i_param{$1} = $2;
3543 }
3544
3545 sub i_resp_previously ($) {
3546     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
3547         or badproto \*RO, "bad previously spec";
3548     my $r = system qw(git check-ref-format), $1;
3549     die "bad previously ref spec ($r)" if $r;
3550     $previously{$1} = $2;
3551 }
3552
3553 our %i_wanted;
3554
3555 sub i_resp_want ($) {
3556     my ($keyword) = @_;
3557     die "$keyword ?" if $i_wanted{$keyword}++;
3558     my @localpaths = i_method "i_want", $keyword;
3559     printdebug "[[  $keyword @localpaths\n";
3560     foreach my $localpath (@localpaths) {
3561         protocol_send_file \*RI, $localpath;
3562     }
3563     print RI "files-end\n" or die $!;
3564 }
3565
3566 our ($i_clogp, $i_version, $i_dscfn, $i_changesfn);
3567
3568 sub i_localname_parsed_changelog {
3569     return "remote-changelog.822";
3570 }
3571 sub i_file_parsed_changelog {
3572     ($i_clogp, $i_version, $i_dscfn) =
3573         push_parse_changelog "$i_tmp/remote-changelog.822";
3574     die if $i_dscfn =~ m#/|^\W#;
3575 }
3576
3577 sub i_localname_dsc {
3578     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3579     return $i_dscfn;
3580 }
3581 sub i_file_dsc { }
3582
3583 sub i_localname_changes {
3584     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
3585     $i_changesfn = $i_dscfn;
3586     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
3587     return $i_changesfn;
3588 }
3589 sub i_file_changes { }
3590
3591 sub i_want_signed_tag {
3592     printdebug Dumper(\%i_param, $i_dscfn);
3593     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
3594         && defined $i_param{'csuite'}
3595         or badproto \*RO, "premature desire for signed-tag";
3596     my $head = $i_param{'head'};
3597     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
3598
3599     my $maintview = $i_param{'maint-view'};
3600     die if defined $maintview && $maintview =~ m/[^0-9a-f]/;
3601
3602     select_tagformat();
3603     if ($protovsn >= 4) {
3604         my $p = $i_param{'tagformat'} // '<undef>';
3605         $p eq $tagformat
3606             or badproto \*RO, "tag format mismatch: $p vs. $tagformat";
3607     }
3608
3609     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
3610     $csuite = $&;
3611     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
3612
3613     my @tagwants = push_tagwants $i_version, $head, $maintview, "tag";
3614
3615     return
3616         push_mktags $i_clogp, $i_dscfn,
3617             $i_changesfn, 'remote changes',
3618             \@tagwants;
3619 }
3620
3621 sub i_want_signed_dsc_changes {
3622     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
3623     sign_changes $i_changesfn;
3624     return ($i_dscfn, $i_changesfn);
3625 }
3626
3627 #---------- building etc. ----------
3628
3629 our $version;
3630 our $sourcechanges;
3631 our $dscfn;
3632
3633 #----- `3.0 (quilt)' handling -----
3634
3635 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
3636
3637 sub quiltify_dpkg_commit ($$$;$) {
3638     my ($patchname,$author,$msg, $xinfo) = @_;
3639     $xinfo //= '';
3640
3641     mkpath '.git/dgit';
3642     my $descfn = ".git/dgit/quilt-description.tmp";
3643     open O, '>', $descfn or die "$descfn: $!";
3644     $msg =~ s/\n+/\n\n/;
3645     print O <<END or die $!;
3646 From: $author
3647 ${xinfo}Subject: $msg
3648 ---
3649
3650 END
3651     close O or die $!;
3652
3653     {
3654         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
3655         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
3656         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
3657         runcmd @dpkgsource, qw(--commit .), $patchname;
3658     }
3659 }
3660
3661 sub quiltify_trees_differ ($$;$$) {
3662     my ($x,$y,$finegrained,$ignorenamesr) = @_;
3663     # returns true iff the two tree objects differ other than in debian/
3664     # with $finegrained,
3665     # returns bitmask 01 - differ in upstream files except .gitignore
3666     #                 02 - differ in .gitignore
3667     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
3668     #  is set for each modified .gitignore filename $fn
3669     local $/=undef;
3670     my @cmd = (@git, qw(diff-tree --name-only -z));
3671     push @cmd, qw(-r) if $finegrained;
3672     push @cmd, $x, $y;
3673     my $diffs= cmdoutput @cmd;
3674     my $r = 0;
3675     foreach my $f (split /\0/, $diffs) {
3676         next if $f =~ m#^debian(?:/.*)?$#s;
3677         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
3678         $r |= $isignore ? 02 : 01;
3679         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
3680     }
3681     printdebug "quiltify_trees_differ $x $y => $r\n";
3682     return $r;
3683 }
3684
3685 sub quiltify_tree_sentinelfiles ($) {
3686     # lists the `sentinel' files present in the tree
3687     my ($x) = @_;
3688     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
3689         qw(-- debian/rules debian/control);
3690     $r =~ s/\n/,/g;
3691     return $r;
3692 }
3693
3694 sub quiltify_splitbrain_needed () {
3695     if (!$split_brain) {
3696         progress "dgit view: changes are required...";
3697         runcmd @git, qw(checkout -q -b dgit-view);
3698         $split_brain = 1;
3699     }
3700 }
3701
3702 sub quiltify_splitbrain ($$$$$$) {
3703     my ($clogp, $unapplied, $headref, $diffbits,
3704         $editedignores, $cachekey) = @_;
3705     if ($quilt_mode !~ m/gbp|dpm/) {
3706         # treat .gitignore just like any other upstream file
3707         $diffbits = { %$diffbits };
3708         $_ = !!$_ foreach values %$diffbits;
3709     }
3710     # We would like any commits we generate to be reproducible
3711     my @authline = clogp_authline($clogp);
3712     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
3713     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
3714     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
3715     local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
3716     local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
3717     local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
3718
3719     if ($quilt_mode =~ m/gbp|unapplied/ &&
3720         ($diffbits->{H2O} & 01)) {
3721         my $msg =
3722  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
3723  " but git tree differs from orig in upstream files.";
3724         if (!stat_exists "debian/patches") {
3725             $msg .=
3726  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
3727         }  
3728         fail $msg;
3729     }
3730     if ($quilt_mode =~ m/dpm/ &&
3731         ($diffbits->{H2A} & 01)) {
3732         fail <<END;
3733 --quilt=$quilt_mode specified, implying patches-applied git tree
3734  but git tree differs from result of applying debian/patches to upstream
3735 END
3736     }
3737     if ($quilt_mode =~ m/gbp|unapplied/ &&
3738         ($diffbits->{O2A} & 01)) { # some patches
3739         quiltify_splitbrain_needed();
3740         progress "dgit view: creating patches-applied version using gbp pq";
3741         runcmd shell_cmd 'exec >/dev/null', gbp_pq, qw(import);
3742         # gbp pq import creates a fresh branch; push back to dgit-view
3743         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
3744         runcmd @git, qw(checkout -q dgit-view);
3745     }
3746     if ($quilt_mode =~ m/gbp|dpm/ &&
3747         ($diffbits->{O2A} & 02)) {
3748         fail <<END
3749 --quilt=$quilt_mode specified, implying that HEAD is for use with a
3750  tool which does not create patches for changes to upstream
3751  .gitignores: but, such patches exist in debian/patches.
3752 END
3753     }
3754     if (($diffbits->{H2O} & 02) && # user