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