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