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