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