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