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