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