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