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