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