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