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