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