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