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