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