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