chiark / gitweb /
7ffbb89b8303d895a6520bb063137c3f2f7c4824
[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         confess "internal error ($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 sub file_in_archive_aptget () { return undef; }
1323
1324 #---------- `dummyapicat' archive query method ----------
1325
1326 sub archive_query_dummycatapi { archive_query_ftpmasterapi @_; }
1327 sub canonicalise_suite_dummycatapi { canonicalise_suite_ftpmasterapi @_; }
1328
1329 sub file_in_archive_dummycatapi ($$$) {
1330     my ($proto,$data,$filename) = @_;
1331     my $mirror = access_cfg('mirror');
1332     $mirror =~ s#^file://#/# or die "$mirror ?";
1333     my @out;
1334     my @cmd = (qw(sh -ec), '
1335             cd "$1"
1336             find -name "$2" -print0 |
1337             xargs -0r sha256sum
1338         ', qw(x), $mirror, $filename);
1339     debugcmd "-|", @cmd;
1340     open FIA, "-|", @cmd or die $!;
1341     while (<FIA>) {
1342         chomp or die;
1343         printdebug "| $_\n";
1344         m/^(\w+)  (\S+)$/ or die "$_ ?";
1345         push @out, { sha256sum => $1, filename => $2 };
1346     }
1347     close FIA or die failedcmd @cmd;
1348     return \@out;
1349 }
1350
1351 #---------- `madison' archive query method ----------
1352
1353 sub archive_query_madison {
1354     return archive_query_prepend_mirror
1355         map { [ @$_[0..1] ] } madison_get_parse(@_);
1356 }
1357
1358 sub madison_get_parse {
1359     my ($proto,$data) = @_;
1360     die unless $proto eq 'madison';
1361     if (!length $data) {
1362         $data= access_cfg('madison-distro','RETURN-UNDEF');
1363         $data //= access_basedistro();
1364     }
1365     $rmad{$proto,$data,$package} ||= cmdoutput
1366         qw(rmadison -asource),"-s$isuite","-u$data",$package;
1367     my $rmad = $rmad{$proto,$data,$package};
1368
1369     my @out;
1370     foreach my $l (split /\n/, $rmad) {
1371         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
1372                   \s*( [^ \t|]+ )\s* \|
1373                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
1374                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
1375         $1 eq $package or die "$rmad $package ?";
1376         my $vsn = $2;
1377         my $newsuite = $3;
1378         my $component;
1379         if (defined $4) {
1380             $component = $4;
1381         } else {
1382             $component = access_cfg('archive-query-default-component');
1383         }
1384         $5 eq 'source' or die "$rmad ?";
1385         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
1386     }
1387     return sort { -version_compare($a->[0],$b->[0]); } @out;
1388 }
1389
1390 sub canonicalise_suite_madison {
1391     # madison canonicalises for us
1392     my @r = madison_get_parse(@_);
1393     @r or fail
1394         "unable to canonicalise suite using package $package".
1395         " which does not appear to exist in suite $isuite;".
1396         " --existing-package may help";
1397     return $r[0][2];
1398 }
1399
1400 sub file_in_archive_madison { return undef; }
1401
1402 #---------- `sshpsql' archive query method ----------
1403
1404 sub sshpsql ($$$) {
1405     my ($data,$runeinfo,$sql) = @_;
1406     if (!length $data) {
1407         $data= access_someuserhost('sshpsql').':'.
1408             access_cfg('sshpsql-dbname');
1409     }
1410     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1411     my ($userhost,$dbname) = ($`,$'); #';
1412     my @rows;
1413     my @cmd = (access_cfg_ssh, $userhost,
1414                access_runeinfo("ssh-psql $runeinfo").
1415                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1416                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1417     debugcmd "|",@cmd;
1418     open P, "-|", @cmd or die $!;
1419     while (<P>) {
1420         chomp or die;
1421         printdebug(">|$_|\n");
1422         push @rows, $_;
1423     }
1424     $!=0; $?=0; close P or failedcmd @cmd;
1425     @rows or die;
1426     my $nrows = pop @rows;
1427     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1428     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1429     @rows = map { [ split /\|/, $_ ] } @rows;
1430     my $ncols = scalar @{ shift @rows };
1431     die if grep { scalar @$_ != $ncols } @rows;
1432     return @rows;
1433 }
1434
1435 sub sql_injection_check {
1436     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1437 }
1438
1439 sub archive_query_sshpsql ($$) {
1440     my ($proto,$data) = @_;
1441     sql_injection_check $isuite, $package;
1442     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1443         SELECT source.version, component.name, files.filename, files.sha256sum
1444           FROM source
1445           JOIN src_associations ON source.id = src_associations.source
1446           JOIN suite ON suite.id = src_associations.suite
1447           JOIN dsc_files ON dsc_files.source = source.id
1448           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1449           JOIN component ON component.id = files_archive_map.component_id
1450           JOIN files ON files.id = dsc_files.file
1451          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1452            AND source.source='$package'
1453            AND files.filename LIKE '%.dsc';
1454 END
1455     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1456     my $digester = Digest::SHA->new(256);
1457     @rows = map {
1458         my ($vsn,$component,$filename,$sha256sum) = @$_;
1459         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1460     } @rows;
1461     return archive_query_prepend_mirror @rows;
1462 }
1463
1464 sub canonicalise_suite_sshpsql ($$) {
1465     my ($proto,$data) = @_;
1466     sql_injection_check $isuite;
1467     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1468         SELECT suite.codename
1469           FROM suite where suite_name='$isuite' or codename='$isuite';
1470 END
1471     @rows = map { $_->[0] } @rows;
1472     fail "unknown suite $isuite" unless @rows;
1473     die "ambiguous $isuite: @rows ?" if @rows>1;
1474     return $rows[0];
1475 }
1476
1477 sub file_in_archive_sshpsql ($$$) { return undef; }
1478
1479 #---------- `dummycat' archive query method ----------
1480
1481 sub canonicalise_suite_dummycat ($$) {
1482     my ($proto,$data) = @_;
1483     my $dpath = "$data/suite.$isuite";
1484     if (!open C, "<", $dpath) {
1485         $!==ENOENT or die "$dpath: $!";
1486         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1487         return $isuite;
1488     }
1489     $!=0; $_ = <C>;
1490     chomp or die "$dpath: $!";
1491     close C;
1492     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1493     return $_;
1494 }
1495
1496 sub archive_query_dummycat ($$) {
1497     my ($proto,$data) = @_;
1498     canonicalise_suite();
1499     my $dpath = "$data/package.$csuite.$package";
1500     if (!open C, "<", $dpath) {
1501         $!==ENOENT or die "$dpath: $!";
1502         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1503         return ();
1504     }
1505     my @rows;
1506     while (<C>) {
1507         next if m/^\#/;
1508         next unless m/\S/;
1509         die unless chomp;
1510         printdebug "dummycat query $csuite $package $dpath | $_\n";
1511         my @row = split /\s+/, $_;
1512         @row==2 or die "$dpath: $_ ?";
1513         push @rows, \@row;
1514     }
1515     C->error and die "$dpath: $!";
1516     close C;
1517     return archive_query_prepend_mirror
1518         sort { -version_compare($a->[0],$b->[0]); } @rows;
1519 }
1520
1521 sub file_in_archive_dummycat () { return undef; }
1522
1523 #---------- tag format handling ----------
1524
1525 sub access_cfg_tagformats () {
1526     split /\,/, access_cfg('dgit-tag-format');
1527 }
1528
1529 sub access_cfg_tagformats_can_splitbrain () {
1530     my %y = map { $_ => 1 } access_cfg_tagformats;
1531     foreach my $needtf (qw(new maint)) {
1532         next if $y{$needtf};
1533         return 0;
1534     }
1535     return 1;
1536 }
1537
1538 sub need_tagformat ($$) {
1539     my ($fmt, $why) = @_;
1540     fail "need to use tag format $fmt ($why) but also need".
1541         " to use tag format $tagformat_want->[0] ($tagformat_want->[1])".
1542         " - no way to proceed"
1543         if $tagformat_want && $tagformat_want->[0] ne $fmt;
1544     $tagformat_want = [$fmt, $why, $tagformat_want->[2] // 0];
1545 }
1546
1547 sub select_tagformat () {
1548     # sets $tagformatfn
1549     return if $tagformatfn && !$tagformat_want;
1550     die 'bug' if $tagformatfn && $tagformat_want;
1551     # ... $tagformat_want assigned after previous select_tagformat
1552
1553     my (@supported) = grep { $_ =~ m/^(?:old|new)$/ } access_cfg_tagformats();
1554     printdebug "select_tagformat supported @supported\n";
1555
1556     $tagformat_want //= [ $supported[0], "distro access configuration", 0 ];
1557     printdebug "select_tagformat specified @$tagformat_want\n";
1558
1559     my ($fmt,$why,$override) = @$tagformat_want;
1560
1561     fail "target distro supports tag formats @supported".
1562         " but have to use $fmt ($why)"
1563         unless $override
1564             or grep { $_ eq $fmt } @supported;
1565
1566     $tagformat_want = undef;
1567     $tagformat = $fmt;
1568     $tagformatfn = ${*::}{"debiantag_$fmt"};
1569
1570     fail "trying to use unknown tag format \`$fmt' ($why) !"
1571         unless $tagformatfn;
1572 }
1573
1574 #---------- archive query entrypoints and rest of program ----------
1575
1576 sub canonicalise_suite () {
1577     return if defined $csuite;
1578     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1579     $csuite = archive_query('canonicalise_suite');
1580     if ($isuite ne $csuite) {
1581         progress "canonical suite name for $isuite is $csuite";
1582     } else {
1583         progress "canonical suite name is $csuite";
1584     }
1585 }
1586
1587 sub get_archive_dsc () {
1588     canonicalise_suite();
1589     my @vsns = archive_query('archive_query');
1590     foreach my $vinfo (@vsns) {
1591         my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1592         $dscurl = $vsn_dscurl;
1593         $dscdata = url_get($dscurl);
1594         if (!$dscdata) {
1595             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1596             next;
1597         }
1598         if ($digester) {
1599             $digester->reset();
1600             $digester->add($dscdata);
1601             my $got = $digester->hexdigest();
1602             $got eq $digest or
1603                 fail "$dscurl has hash $got but".
1604                     " archive told us to expect $digest";
1605         }
1606         parse_dscdata();
1607         my $fmt = getfield $dsc, 'Format';
1608         $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1609             "unsupported source format $fmt, sorry";
1610             
1611         $dsc_checked = !!$digester;
1612         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1613         return;
1614     }
1615     $dsc = undef;
1616     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1617 }
1618
1619 sub check_for_git ();
1620 sub check_for_git () {
1621     # returns 0 or 1
1622     my $how = access_cfg('git-check');
1623     if ($how eq 'ssh-cmd') {
1624         my @cmd =
1625             (access_cfg_ssh, access_gituserhost(),
1626              access_runeinfo("git-check $package").
1627              " set -e; cd ".access_cfg('git-path').";".
1628              " if test -d $package.git; then echo 1; else echo 0; fi");
1629         my $r= cmdoutput @cmd;
1630         if (defined $r and $r =~ m/^divert (\w+)$/) {
1631             my $divert=$1;
1632             my ($usedistro,) = access_distros();
1633             # NB that if we are pushing, $usedistro will be $distro/push
1634             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1635             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1636             progress "diverting to $divert (using config for $instead_distro)";
1637             return check_for_git();
1638         }
1639         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1640         return $r+0;
1641     } elsif ($how eq 'url') {
1642         my $prefix = access_cfg('git-check-url','git-url');
1643         my $suffix = access_cfg('git-check-suffix','git-suffix',
1644                                 'RETURN-UNDEF') // '.git';
1645         my $url = "$prefix/$package$suffix";
1646         my @cmd = (@curl, qw(-sS -I), $url);
1647         my $result = cmdoutput @cmd;
1648         $result =~ s/^\S+ 200 .*\n\r?\n//;
1649         # curl -sS -I with https_proxy prints
1650         # HTTP/1.0 200 Connection established
1651         $result =~ m/^\S+ (404|200) /s or
1652             fail "unexpected results from git check query - ".
1653                 Dumper($prefix, $result);
1654         my $code = $1;
1655         if ($code eq '404') {
1656             return 0;
1657         } elsif ($code eq '200') {
1658             return 1;
1659         } else {
1660             die;
1661         }
1662     } elsif ($how eq 'true') {
1663         return 1;
1664     } elsif ($how eq 'false') {
1665         return 0;
1666     } else {
1667         badcfg "unknown git-check \`$how'";
1668     }
1669 }
1670
1671 sub create_remote_git_repo () {
1672     my $how = access_cfg('git-create');
1673     if ($how eq 'ssh-cmd') {
1674         runcmd_ordryrun
1675             (access_cfg_ssh, access_gituserhost(),
1676              access_runeinfo("git-create $package").
1677              "set -e; cd ".access_cfg('git-path').";".
1678              " cp -a _template $package.git");
1679     } elsif ($how eq 'true') {
1680         # nothing to do
1681     } else {
1682         badcfg "unknown git-create \`$how'";
1683     }
1684 }
1685
1686 our ($dsc_hash,$lastpush_mergeinput);
1687 our ($dsc_distro, $dsc_hint_tag, $dsc_hint_url);
1688
1689 our $ud = '.git/dgit/unpack';
1690
1691 sub prep_ud (;$) {
1692     my ($d) = @_;
1693     $d //= $ud;
1694     rmtree($d);
1695     mkpath '.git/dgit';
1696     mkdir $d or die $!;
1697 }
1698
1699 sub mktree_in_ud_here () {
1700     runcmd qw(git init -q);
1701     runcmd qw(git config gc.auto 0);
1702     foreach my $copy (qw(user.email user.name user.useConfigOnly)) {
1703         my $v = $gitcfgs{local}{$copy};
1704         next unless $v;
1705         runcmd qw(git config), $copy, $_ foreach @$v;
1706     }
1707     rmtree('.git/objects');
1708     symlink '../../../../objects','.git/objects' or die $!;
1709     setup_gitattrs(1);
1710 }
1711
1712 sub git_write_tree () {
1713     my $tree = cmdoutput @git, qw(write-tree);
1714     $tree =~ m/^\w+$/ or die "$tree ?";
1715     return $tree;
1716 }
1717
1718 sub git_add_write_tree () {
1719     runcmd @git, qw(add -Af .);
1720     return git_write_tree();
1721 }
1722
1723 sub remove_stray_gits ($) {
1724     my ($what) = @_;
1725     my @gitscmd = qw(find -name .git -prune -print0);
1726     debugcmd "|",@gitscmd;
1727     open GITS, "-|", @gitscmd or die $!;
1728     {
1729         local $/="\0";
1730         while (<GITS>) {
1731             chomp or die;
1732             print STDERR "$us: warning: removing from $what: ",
1733                 (messagequote $_), "\n";
1734             rmtree $_;
1735         }
1736     }
1737     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1738 }
1739
1740 sub mktree_in_ud_from_only_subdir ($;$) {
1741     my ($what,$raw) = @_;
1742
1743     # changes into the subdir
1744     my (@dirs) = <*/.>;
1745     die "expected one subdir but found @dirs ?" unless @dirs==1;
1746     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1747     my $dir = $1;
1748     changedir $dir;
1749
1750     remove_stray_gits($what);
1751     mktree_in_ud_here();
1752     if (!$raw) {
1753         my ($format, $fopts) = get_source_format();
1754         if (madformat($format)) {
1755             rmtree '.pc';
1756         }
1757     }
1758
1759     my $tree=git_add_write_tree();
1760     return ($tree,$dir);
1761 }
1762
1763 our @files_csum_info_fields = 
1764     (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1765      ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
1766      ['Files',           'Digest::MD5', 'new()',    'md5sum']);
1767
1768 sub dsc_files_info () {
1769     foreach my $csumi (@files_csum_info_fields) {
1770         my ($fname, $module, $method) = @$csumi;
1771         my $field = $dsc->{$fname};
1772         next unless defined $field;
1773         eval "use $module; 1;" or die $@;
1774         my @out;
1775         foreach (split /\n/, $field) {
1776             next unless m/\S/;
1777             m/^(\w+) (\d+) (\S+)$/ or
1778                 fail "could not parse .dsc $fname line \`$_'";
1779             my $digester = eval "$module"."->$method;" or die $@;
1780             push @out, {
1781                 Hash => $1,
1782                 Bytes => $2,
1783                 Filename => $3,
1784                 Digester => $digester,
1785             };
1786         }
1787         return @out;
1788     }
1789     fail "missing any supported Checksums-* or Files field in ".
1790         $dsc->get_option('name');
1791 }
1792
1793 sub dsc_files () {
1794     map { $_->{Filename} } dsc_files_info();
1795 }
1796
1797 sub files_compare_inputs (@) {
1798     my $inputs = \@_;
1799     my %record;
1800     my %fchecked;
1801
1802     my $showinputs = sub {
1803         return join "; ", map { $_->get_option('name') } @$inputs;
1804     };
1805
1806     foreach my $in (@$inputs) {
1807         my $expected_files;
1808         my $in_name = $in->get_option('name');
1809
1810         printdebug "files_compare_inputs $in_name\n";
1811
1812         foreach my $csumi (@files_csum_info_fields) {
1813             my ($fname) = @$csumi;
1814             printdebug "files_compare_inputs $in_name $fname\n";
1815
1816             my $field = $in->{$fname};
1817             next unless defined $field;
1818
1819             my @files;
1820             foreach (split /\n/, $field) {
1821                 next unless m/\S/;
1822
1823                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1824                     fail "could not parse $in_name $fname line \`$_'";
1825
1826                 printdebug "files_compare_inputs $in_name $fname $f\n";
1827
1828                 push @files, $f;
1829
1830                 my $re = \ $record{$f}{$fname};
1831                 if (defined $$re) {
1832                     $fchecked{$f}{$in_name} = 1;
1833                     $$re eq $info or
1834                         fail "hash or size of $f varies in $fname fields".
1835                         " (between: ".$showinputs->().")";
1836                 } else {
1837                     $$re = $info;
1838                 }
1839             }
1840             @files = sort @files;
1841             $expected_files //= \@files;
1842             "@$expected_files" eq "@files" or
1843                 fail "file list in $in_name varies between hash fields!";
1844         }
1845         $expected_files or
1846             fail "$in_name has no files list field(s)";
1847     }
1848     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1849         if $debuglevel>=2;
1850
1851     grep { keys %$_ == @$inputs-1 } values %fchecked
1852         or fail "no file appears in all file lists".
1853         " (looked in: ".$showinputs->().")";
1854 }
1855
1856 sub is_orig_file_in_dsc ($$) {
1857     my ($f, $dsc_files_info) = @_;
1858     return 0 if @$dsc_files_info <= 1;
1859     # One file means no origs, and the filename doesn't have a "what
1860     # part of dsc" component.  (Consider versions ending `.orig'.)
1861     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1862     return 1;
1863 }
1864
1865 sub is_orig_file_of_vsn ($$) {
1866     my ($f, $upstreamvsn) = @_;
1867     my $base = srcfn $upstreamvsn, '';
1868     return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1869     return 1;
1870 }
1871
1872 sub changes_update_origs_from_dsc ($$$$) {
1873     my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1874     my %changes_f;
1875     printdebug "checking origs needed ($upstreamvsn)...\n";
1876     $_ = getfield $changes, 'Files';
1877     m/^\w+ \d+ (\S+ \S+) \S+$/m or
1878         fail "cannot find section/priority from .changes Files field";
1879     my $placementinfo = $1;
1880     my %changed;
1881     printdebug "checking origs needed placement '$placementinfo'...\n";
1882     foreach my $l (split /\n/, getfield $dsc, 'Files') {
1883         $l =~ m/\S+$/ or next;
1884         my $file = $&;
1885         printdebug "origs $file | $l\n";
1886         next unless is_orig_file_of_vsn $file, $upstreamvsn;
1887         printdebug "origs $file is_orig\n";
1888         my $have = archive_query('file_in_archive', $file);
1889         if (!defined $have) {
1890             print STDERR <<END;
1891 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1892 END
1893             return;
1894         }
1895         my $found_same = 0;
1896         my @found_differ;
1897         printdebug "origs $file \$#\$have=$#$have\n";
1898         foreach my $h (@$have) {
1899             my $same = 0;
1900             my @differ;
1901             foreach my $csumi (@files_csum_info_fields) {
1902                 my ($fname, $module, $method, $archivefield) = @$csumi;
1903                 next unless defined $h->{$archivefield};
1904                 $_ = $dsc->{$fname};
1905                 next unless defined;
1906                 m/^(\w+) .* \Q$file\E$/m or
1907                     fail ".dsc $fname missing entry for $file";
1908                 if ($h->{$archivefield} eq $1) {
1909                     $same++;
1910                 } else {
1911                     push @differ,
1912  "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1913                 }
1914             }
1915             die "$file ".Dumper($h)." ?!" if $same && @differ;
1916             $found_same++
1917                 if $same;
1918             push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1919                 if @differ;
1920         }
1921         printdebug "origs $file f.same=$found_same".
1922             " #f._differ=$#found_differ\n";
1923         if (@found_differ && !$found_same) {
1924             fail join "\n",
1925                 "archive contains $file with different checksum",
1926                 @found_differ;
1927         }
1928         # Now we edit the changes file to add or remove it
1929         foreach my $csumi (@files_csum_info_fields) {
1930             my ($fname, $module, $method, $archivefield) = @$csumi;
1931             next unless defined $changes->{$fname};
1932             if ($found_same) {
1933                 # in archive, delete from .changes if it's there
1934                 $changed{$file} = "removed" if
1935                     $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1936             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1937                 # not in archive, but it's here in the .changes
1938             } else {
1939                 my $dsc_data = getfield $dsc, $fname;
1940                 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1941                 my $extra = $1;
1942                 $extra =~ s/ \d+ /$&$placementinfo /
1943                     or die "$fname $extra >$dsc_data< ?"
1944                     if $fname eq 'Files';
1945                 $changes->{$fname} .= "\n". $extra;
1946                 $changed{$file} = "added";
1947             }
1948         }
1949     }
1950     if (%changed) {
1951         foreach my $file (keys %changed) {
1952             progress sprintf
1953                 "edited .changes for archive .orig contents: %s %s",
1954                 $changed{$file}, $file;
1955         }
1956         my $chtmp = "$changesfile.tmp";
1957         $changes->save($chtmp);
1958         if (act_local()) {
1959             rename $chtmp,$changesfile or die "$changesfile $!";
1960         } else {
1961             progress "[new .changes left in $changesfile]";
1962         }
1963     } else {
1964         progress "$changesfile already has appropriate .orig(s) (if any)";
1965     }
1966 }
1967
1968 sub make_commit ($) {
1969     my ($file) = @_;
1970     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1971 }
1972
1973 sub make_commit_text ($) {
1974     my ($text) = @_;
1975     my ($out, $in);
1976     my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1977     debugcmd "|",@cmd;
1978     print Dumper($text) if $debuglevel > 1;
1979     my $child = open2($out, $in, @cmd) or die $!;
1980     my $h;
1981     eval {
1982         print $in $text or die $!;
1983         close $in or die $!;
1984         $h = <$out>;
1985         $h =~ m/^\w+$/ or die;
1986         $h = $&;
1987         printdebug "=> $h\n";
1988     };
1989     close $out;
1990     waitpid $child, 0 == $child or die "$child $!";
1991     $? and failedcmd @cmd;
1992     return $h;
1993 }
1994
1995 sub clogp_authline ($) {
1996     my ($clogp) = @_;
1997     my $author = getfield $clogp, 'Maintainer';
1998     $author =~ s#,.*##ms;
1999     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
2000     my $authline = "$author $date";
2001     $authline =~ m/$git_authline_re/o or
2002         fail "unexpected commit author line format \`$authline'".
2003         " (was generated from changelog Maintainer field)";
2004     return ($1,$2,$3) if wantarray;
2005     return $authline;
2006 }
2007
2008 sub vendor_patches_distro ($$) {
2009     my ($checkdistro, $what) = @_;
2010     return unless defined $checkdistro;
2011
2012     my $series = "debian/patches/\L$checkdistro\E.series";
2013     printdebug "checking for vendor-specific $series ($what)\n";
2014
2015     if (!open SERIES, "<", $series) {
2016         die "$series $!" unless $!==ENOENT;
2017         return;
2018     }
2019     while (<SERIES>) {
2020         next unless m/\S/;
2021         next if m/^\s+\#/;
2022
2023         print STDERR <<END;
2024
2025 Unfortunately, this source package uses a feature of dpkg-source where
2026 the same source package unpacks to different source code on different
2027 distros.  dgit cannot safely operate on such packages on affected
2028 distros, because the meaning of source packages is not stable.
2029
2030 Please ask the distro/maintainer to remove the distro-specific series
2031 files and use a different technique (if necessary, uploading actually
2032 different packages, if different distros are supposed to have
2033 different code).
2034
2035 END
2036         fail "Found active distro-specific series file for".
2037             " $checkdistro ($what): $series, cannot continue";
2038     }
2039     die "$series $!" if SERIES->error;
2040     close SERIES;
2041 }
2042
2043 sub check_for_vendor_patches () {
2044     # This dpkg-source feature doesn't seem to be documented anywhere!
2045     # But it can be found in the changelog (reformatted):
2046
2047     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
2048     #   Author: Raphael Hertzog <hertzog@debian.org>
2049     #   Date: Sun  Oct  3  09:36:48  2010 +0200
2050
2051     #   dpkg-source: correctly create .pc/.quilt_series with alternate
2052     #   series files
2053     #   
2054     #   If you have debian/patches/ubuntu.series and you were
2055     #   unpacking the source package on ubuntu, quilt was still
2056     #   directed to debian/patches/series instead of
2057     #   debian/patches/ubuntu.series.
2058     #   
2059     #   debian/changelog                        |    3 +++
2060     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
2061     #   2 files changed, 6 insertions(+), 1 deletion(-)
2062
2063     use Dpkg::Vendor;
2064     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2065     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2066                          "Dpkg::Vendor \`current vendor'");
2067     vendor_patches_distro(access_basedistro(),
2068                           "(base) distro being accessed");
2069     vendor_patches_distro(access_nomdistro(),
2070                           "(nominal) distro being accessed");
2071 }
2072
2073 sub generate_commits_from_dsc () {
2074     # See big comment in fetch_from_archive, below.
2075     # See also README.dsc-import.
2076     prep_ud();
2077     changedir $ud;
2078
2079     my @dfi = dsc_files_info();
2080     foreach my $fi (@dfi) {
2081         my $f = $fi->{Filename};
2082         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2083         my $upper_f = "../../../../$f";
2084
2085         printdebug "considering reusing $f: ";
2086
2087         if (link_ltarget "$upper_f,fetch", $f) {
2088             printdebug "linked (using ...,fetch).\n";
2089         } elsif ((printdebug "($!) "),
2090                  $! != ENOENT) {
2091             fail "accessing ../$f,fetch: $!";
2092         } elsif (link_ltarget $upper_f, $f) {
2093             printdebug "linked.\n";
2094         } elsif ((printdebug "($!) "),
2095                  $! != ENOENT) {
2096             fail "accessing ../$f: $!";
2097         } else {
2098             printdebug "absent.\n";
2099         }
2100
2101         my $refetched;
2102         complete_file_from_dsc('.', $fi, \$refetched)
2103             or next;
2104
2105         printdebug "considering saving $f: ";
2106
2107         if (link $f, $upper_f) {
2108             printdebug "linked.\n";
2109         } elsif ((printdebug "($!) "),
2110                  $! != EEXIST) {
2111             fail "saving ../$f: $!";
2112         } elsif (!$refetched) {
2113             printdebug "no need.\n";
2114         } elsif (link $f, "$upper_f,fetch") {
2115             printdebug "linked (using ...,fetch).\n";
2116         } elsif ((printdebug "($!) "),
2117                  $! != EEXIST) {
2118             fail "saving ../$f,fetch: $!";
2119         } else {
2120             printdebug "cannot.\n";
2121         }
2122     }
2123
2124     # We unpack and record the orig tarballs first, so that we only
2125     # need disk space for one private copy of the unpacked source.
2126     # But we can't make them into commits until we have the metadata
2127     # from the debian/changelog, so we record the tree objects now and
2128     # make them into commits later.
2129     my @tartrees;
2130     my $upstreamv = upstreamversion $dsc->{version};
2131     my $orig_f_base = srcfn $upstreamv, '';
2132
2133     foreach my $fi (@dfi) {
2134         # We actually import, and record as a commit, every tarball
2135         # (unless there is only one file, in which case there seems
2136         # little point.
2137
2138         my $f = $fi->{Filename};
2139         printdebug "import considering $f ";
2140         (printdebug "only one dfi\n"), next if @dfi == 1;
2141         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2142         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2143         my $compr_ext = $1;
2144
2145         my ($orig_f_part) =
2146             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2147
2148         printdebug "Y ", (join ' ', map { $_//"(none)" }
2149                           $compr_ext, $orig_f_part
2150                          ), "\n";
2151
2152         my $input = new IO::File $f, '<' or die "$f $!";
2153         my $compr_pid;
2154         my @compr_cmd;
2155
2156         if (defined $compr_ext) {
2157             my $cname =
2158                 Dpkg::Compression::compression_guess_from_filename $f;
2159             fail "Dpkg::Compression cannot handle file $f in source package"
2160                 if defined $compr_ext && !defined $cname;
2161             my $compr_proc =
2162                 new Dpkg::Compression::Process compression => $cname;
2163             my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2164             my $compr_fh = new IO::Handle;
2165             my $compr_pid = open $compr_fh, "-|" // die $!;
2166             if (!$compr_pid) {
2167                 open STDIN, "<&", $input or die $!;
2168                 exec @compr_cmd;
2169                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2170             }
2171             $input = $compr_fh;
2172         }
2173
2174         rmtree "_unpack-tar";
2175         mkdir "_unpack-tar" or die $!;
2176         my @tarcmd = qw(tar -x -f -
2177                         --no-same-owner --no-same-permissions
2178                         --no-acls --no-xattrs --no-selinux);
2179         my $tar_pid = fork // die $!;
2180         if (!$tar_pid) {
2181             chdir "_unpack-tar" or die $!;
2182             open STDIN, "<&", $input or die $!;
2183             exec @tarcmd;
2184             die "dgit (child): exec $tarcmd[0]: $!";
2185         }
2186         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2187         !$? or failedcmd @tarcmd;
2188
2189         close $input or
2190             (@compr_cmd ? failedcmd @compr_cmd
2191              : die $!);
2192         # finally, we have the results in "tarball", but maybe
2193         # with the wrong permissions
2194
2195         runcmd qw(chmod -R +rwX _unpack-tar);
2196         changedir "_unpack-tar";
2197         remove_stray_gits($f);
2198         mktree_in_ud_here();
2199         
2200         my ($tree) = git_add_write_tree();
2201         my $tentries = cmdoutput @git, qw(ls-tree -z), $tree;
2202         if ($tentries =~ m/^\d+ tree (\w+)\t[^\000]+\000$/s) {
2203             $tree = $1;
2204             printdebug "one subtree $1\n";
2205         } else {
2206             printdebug "multiple subtrees\n";
2207         }
2208         changedir "..";
2209         rmtree "_unpack-tar";
2210
2211         my $ent = [ $f, $tree ];
2212         push @tartrees, {
2213             Orig => !!$orig_f_part,
2214             Sort => (!$orig_f_part         ? 2 :
2215                      $orig_f_part =~ m/-/g ? 1 :
2216                                              0),
2217             F => $f,
2218             Tree => $tree,
2219         };
2220     }
2221
2222     @tartrees = sort {
2223         # put any without "_" first (spec is not clear whether files
2224         # are always in the usual order).  Tarballs without "_" are
2225         # the main orig or the debian tarball.
2226         $a->{Sort} <=> $b->{Sort} or
2227         $a->{F}    cmp $b->{F}
2228     } @tartrees;
2229
2230     my $any_orig = grep { $_->{Orig} } @tartrees;
2231
2232     my $dscfn = "$package.dsc";
2233
2234     my $treeimporthow = 'package';
2235
2236     open D, ">", $dscfn or die "$dscfn: $!";
2237     print D $dscdata or die "$dscfn: $!";
2238     close D or die "$dscfn: $!";
2239     my @cmd = qw(dpkg-source);
2240     push @cmd, '--no-check' if $dsc_checked;
2241     if (madformat $dsc->{format}) {
2242         push @cmd, '--skip-patches';
2243         $treeimporthow = 'unpatched';
2244     }
2245     push @cmd, qw(-x --), $dscfn;
2246     runcmd @cmd;
2247
2248     my ($tree,$dir) = mktree_in_ud_from_only_subdir("source package");
2249     if (madformat $dsc->{format}) { 
2250         check_for_vendor_patches();
2251     }
2252
2253     my $dappliedtree;
2254     if (madformat $dsc->{format}) {
2255         my @pcmd = qw(dpkg-source --before-build .);
2256         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2257         rmtree '.pc';
2258         $dappliedtree = git_add_write_tree();
2259     }
2260
2261     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2262     debugcmd "|",@clogcmd;
2263     open CLOGS, "-|", @clogcmd or die $!;
2264
2265     my $clogp;
2266     my $r1clogp;
2267
2268     printdebug "import clog search...\n";
2269
2270     for (;;) {
2271         my $stanzatext = do { local $/=""; <CLOGS>; };
2272         printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2273         last if !defined $stanzatext;
2274
2275         my $desc = "package changelog, entry no.$.";
2276         open my $stanzafh, "<", \$stanzatext or die;
2277         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2278         $clogp //= $thisstanza;
2279
2280         printdebug "import clog $thisstanza->{version} $desc...\n";
2281
2282         last if !$any_orig; # we don't need $r1clogp
2283
2284         # We look for the first (most recent) changelog entry whose
2285         # version number is lower than the upstream version of this
2286         # package.  Then the last (least recent) previous changelog
2287         # entry is treated as the one which introduced this upstream
2288         # version and used for the synthetic commits for the upstream
2289         # tarballs.
2290
2291         # One might think that a more sophisticated algorithm would be
2292         # necessary.  But: we do not want to scan the whole changelog
2293         # file.  Stopping when we see an earlier version, which
2294         # necessarily then is an earlier upstream version, is the only
2295         # realistic way to do that.  Then, either the earliest
2296         # changelog entry we have seen so far is indeed the earliest
2297         # upload of this upstream version; or there are only changelog
2298         # entries relating to later upstream versions (which is not
2299         # possible unless the changelog and .dsc disagree about the
2300         # version).  Then it remains to choose between the physically
2301         # last entry in the file, and the one with the lowest version
2302         # number.  If these are not the same, we guess that the
2303         # versions were created in a non-monotic order rather than
2304         # that the changelog entries have been misordered.
2305
2306         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2307
2308         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2309         $r1clogp = $thisstanza;
2310
2311         printdebug "import clog $r1clogp->{version} becomes r1\n";
2312     }
2313     die $! if CLOGS->error;
2314     close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2315
2316     $clogp or fail "package changelog has no entries!";
2317
2318     my $authline = clogp_authline $clogp;
2319     my $changes = getfield $clogp, 'Changes';
2320     my $cversion = getfield $clogp, 'Version';
2321
2322     if (@tartrees) {
2323         $r1clogp //= $clogp; # maybe there's only one entry;
2324         my $r1authline = clogp_authline $r1clogp;
2325         # Strictly, r1authline might now be wrong if it's going to be
2326         # unused because !$any_orig.  Whatever.
2327
2328         printdebug "import tartrees authline   $authline\n";
2329         printdebug "import tartrees r1authline $r1authline\n";
2330
2331         foreach my $tt (@tartrees) {
2332             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2333
2334             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2335 tree $tt->{Tree}
2336 author $r1authline
2337 committer $r1authline
2338
2339 Import $tt->{F}
2340
2341 [dgit import orig $tt->{F}]
2342 END_O
2343 tree $tt->{Tree}
2344 author $authline
2345 committer $authline
2346
2347 Import $tt->{F}
2348
2349 [dgit import tarball $package $cversion $tt->{F}]
2350 END_T
2351         }
2352     }
2353
2354     printdebug "import main commit\n";
2355
2356     open C, ">../commit.tmp" or die $!;
2357     print C <<END or die $!;
2358 tree $tree
2359 END
2360     print C <<END or die $! foreach @tartrees;
2361 parent $_->{Commit}
2362 END
2363     print C <<END or die $!;
2364 author $authline
2365 committer $authline
2366
2367 $changes
2368
2369 [dgit import $treeimporthow $package $cversion]
2370 END
2371
2372     close C or die $!;
2373     my $rawimport_hash = make_commit qw(../commit.tmp);
2374
2375     if (madformat $dsc->{format}) {
2376         printdebug "import apply patches...\n";
2377
2378         # regularise the state of the working tree so that
2379         # the checkout of $rawimport_hash works nicely.
2380         my $dappliedcommit = make_commit_text(<<END);
2381 tree $dappliedtree
2382 author $authline
2383 committer $authline
2384
2385 [dgit dummy commit]
2386 END
2387         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2388
2389         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2390
2391         # We need the answers to be reproducible
2392         my @authline = clogp_authline($clogp);
2393         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2394         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2395         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2396         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2397         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2398         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2399
2400         my $path = $ENV{PATH} or die;
2401
2402         foreach my $use_absurd (qw(0 1)) {
2403             runcmd @git, qw(checkout -q unpa);
2404             runcmd @git, qw(update-ref -d refs/heads/patch-queue/unpa);
2405             local $ENV{PATH} = $path;
2406             if ($use_absurd) {
2407                 chomp $@;
2408                 progress "warning: $@";
2409                 $path = "$absurdity:$path";
2410                 progress "$us: trying slow absurd-git-apply...";
2411                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2412                     or $!==ENOENT
2413                     or die $!;
2414             }
2415             eval {
2416                 die "forbid absurd git-apply\n" if $use_absurd
2417                     && forceing [qw(import-gitapply-no-absurd)];
2418                 die "only absurd git-apply!\n" if !$use_absurd
2419                     && forceing [qw(import-gitapply-absurd)];
2420
2421                 local $ENV{DGIT_ABSURD_DEBUG} = $debuglevel if $use_absurd;
2422                 local $ENV{PATH} = $path                    if $use_absurd;
2423
2424                 my @showcmd = (gbp_pq, qw(import));
2425                 my @realcmd = shell_cmd
2426                     'exec >/dev/null 2>>../../gbp-pq-output', @showcmd;
2427                 debugcmd "+",@realcmd;
2428                 if (system @realcmd) {
2429                     die +(shellquote @showcmd).
2430                         " failed: ".
2431                         failedcmd_waitstatus()."\n";
2432                 }
2433
2434                 my $gapplied = git_rev_parse('HEAD');
2435                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2436                 $gappliedtree eq $dappliedtree or
2437                     fail <<END;
2438 gbp-pq import and dpkg-source disagree!
2439  gbp-pq import gave commit $gapplied
2440  gbp-pq import gave tree $gappliedtree
2441  dpkg-source --before-build gave tree $dappliedtree
2442 END
2443                 $rawimport_hash = $gapplied;
2444             };
2445             last unless $@;
2446         }
2447         if ($@) {
2448             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2449             die $@;
2450         }
2451     }
2452
2453     progress "synthesised git commit from .dsc $cversion";
2454
2455     my $rawimport_mergeinput = {
2456         Commit => $rawimport_hash,
2457         Info => "Import of source package",
2458     };
2459     my @output = ($rawimport_mergeinput);
2460
2461     if ($lastpush_mergeinput) {
2462         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2463         my $oversion = getfield $oldclogp, 'Version';
2464         my $vcmp =
2465             version_compare($oversion, $cversion);
2466         if ($vcmp < 0) {
2467             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2468                 { Message => <<END, ReverseParents => 1 });
2469 Record $package ($cversion) in archive suite $csuite
2470 END
2471         } elsif ($vcmp > 0) {
2472             print STDERR <<END or die $!;
2473
2474 Version actually in archive:   $cversion (older)
2475 Last version pushed with dgit: $oversion (newer or same)
2476 $later_warning_msg
2477 END
2478             @output = $lastpush_mergeinput;
2479         } else {
2480             # Same version.  Use what's in the server git branch,
2481             # discarding our own import.  (This could happen if the
2482             # server automatically imports all packages into git.)
2483             @output = $lastpush_mergeinput;
2484         }
2485     }
2486     changedir '../../../..';
2487     rmtree($ud);
2488     return @output;
2489 }
2490
2491 sub complete_file_from_dsc ($$;$) {
2492     our ($dstdir, $fi, $refetched) = @_;
2493     # Ensures that we have, in $dstdir, the file $fi, with the correct
2494     # contents.  (Downloading it from alongside $dscurl if necessary.)
2495     # If $refetched is defined, can overwrite "$dstdir/$fi->{Filename}"
2496     # and will set $$refetched=1 if it did so (or tried to).
2497
2498     my $f = $fi->{Filename};
2499     my $tf = "$dstdir/$f";
2500     my $downloaded = 0;
2501
2502     my $got;
2503     my $checkhash = sub {
2504         open F, "<", "$tf" or die "$tf: $!";
2505         $fi->{Digester}->reset();
2506         $fi->{Digester}->addfile(*F);
2507         F->error and die $!;
2508         my $got = $fi->{Digester}->hexdigest();
2509         return $got eq $fi->{Hash};
2510     };
2511
2512     if (stat_exists $tf) {
2513         if ($checkhash->()) {
2514             progress "using existing $f";
2515             return 1;
2516         }
2517         if (!$refetched) {
2518             fail "file $f has hash $got but .dsc".
2519                 " demands hash $fi->{Hash} ".
2520                 "(perhaps you should delete this file?)";
2521         }
2522         progress "need to fetch correct version of $f";
2523         unlink $tf or die "$tf $!";
2524         $$refetched = 1;
2525     } else {
2526         printdebug "$tf does not exist, need to fetch\n";
2527     }
2528
2529     my $furl = $dscurl;
2530     $furl =~ s{/[^/]+$}{};
2531     $furl .= "/$f";
2532     die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2533     die "$f ?" if $f =~ m#/#;
2534     runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2535     return 0 if !act_local();
2536
2537     $checkhash->() or
2538         fail "file $f has hash $got but .dsc".
2539             " demands hash $fi->{Hash} ".
2540             "(got wrong file from archive!)";
2541
2542     return 1;
2543 }
2544
2545 sub ensure_we_have_orig () {
2546     my @dfi = dsc_files_info();
2547     foreach my $fi (@dfi) {
2548         my $f = $fi->{Filename};
2549         next unless is_orig_file_in_dsc($f, \@dfi);
2550         complete_file_from_dsc('..', $fi)
2551             or next;
2552     }
2553 }
2554
2555 #---------- git fetch ----------
2556
2557 sub lrfetchrefs () { return "refs/dgit-fetch/".access_basedistro(); }
2558 sub lrfetchref () { return lrfetchrefs.'/'.server_branch($csuite); }
2559
2560 # We fetch some parts of lrfetchrefs/*.  Ideally we delete these
2561 # locally fetched refs because they have unhelpful names and clutter
2562 # up gitk etc.  So we track whether we have "used up" head ref (ie,
2563 # whether we have made another local ref which refers to this object).
2564 #
2565 # (If we deleted them unconditionally, then we might end up
2566 # re-fetching the same git objects each time dgit fetch was run.)
2567 #
2568 # So, each use of lrfetchrefs needs to be accompanied by arrangements
2569 # in git_fetch_us to fetch the refs in question, and possibly a call
2570 # to lrfetchref_used.
2571
2572 our (%lrfetchrefs_f, %lrfetchrefs_d);
2573 # $lrfetchrefs_X{lrfetchrefs."/heads/whatever"} = $objid
2574
2575 sub lrfetchref_used ($) {
2576     my ($fullrefname) = @_;
2577     my $objid = $lrfetchrefs_f{$fullrefname};
2578     $lrfetchrefs_d{$fullrefname} = $objid if defined $objid;
2579 }
2580
2581 sub git_lrfetch_sane {
2582     my ($url, $supplementary, @specs) = @_;
2583     # Make a 'refs/'.lrfetchrefs.'/*' be just like on server,
2584     # at least as regards @specs.  Also leave the results in
2585     # %lrfetchrefs_f, and arrange for lrfetchref_used to be
2586     # able to clean these up.
2587     #
2588     # With $supplementary==1, @specs must not contain wildcards
2589     # and we add to our previous fetches (non-atomically).
2590
2591     # This is rather miserable:
2592     # When git fetch --prune is passed a fetchspec ending with a *,
2593     # it does a plausible thing.  If there is no * then:
2594     # - it matches subpaths too, even if the supplied refspec
2595     #   starts refs, and behaves completely madly if the source
2596     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2597     # - if there is no matching remote ref, it bombs out the whole
2598     #   fetch.
2599     # We want to fetch a fixed ref, and we don't know in advance
2600     # if it exists, so this is not suitable.
2601     #
2602     # Our workaround is to use git ls-remote.  git ls-remote has its
2603     # own qairks.  Notably, it has the absurd multi-tail-matching
2604     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2605     # refs/refs/foo etc.
2606     #
2607     # Also, we want an idempotent snapshot, but we have to make two
2608     # calls to the remote: one to git ls-remote and to git fetch.  The
2609     # solution is use git ls-remote to obtain a target state, and
2610     # git fetch to try to generate it.  If we don't manage to generate
2611     # the target state, we try again.
2612
2613     printdebug "git_lrfetch_sane suppl=$supplementary specs @specs\n";
2614
2615     my $specre = join '|', map {
2616         my $x = $_;
2617         $x =~ s/\W/\\$&/g;
2618         my $wildcard = $x =~ s/\\\*$/.*/;
2619         die if $wildcard && $supplementary;
2620         "(?:refs/$x)";
2621     } @specs;
2622     printdebug "git_lrfetch_sane specre=$specre\n";
2623     my $wanted_rref = sub {
2624         local ($_) = @_;
2625         return m/^(?:$specre)$/;
2626     };
2627
2628     my $fetch_iteration = 0;
2629     FETCH_ITERATION:
2630     for (;;) {
2631         printdebug "git_lrfetch_sane iteration $fetch_iteration\n";
2632         if (++$fetch_iteration > 10) {
2633             fail "too many iterations trying to get sane fetch!";
2634         }
2635
2636         my @look = map { "refs/$_" } @specs;
2637         my @lcmd = (@git, qw(ls-remote -q --refs), $url, @look);
2638         debugcmd "|",@lcmd;
2639
2640         my %wantr;
2641         open GITLS, "-|", @lcmd or die $!;
2642         while (<GITLS>) {
2643             printdebug "=> ", $_;
2644             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2645             my ($objid,$rrefname) = ($1,$2);
2646             if (!$wanted_rref->($rrefname)) {
2647                 print STDERR <<END;
2648 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2649 END
2650                 next;
2651             }
2652             $wantr{$rrefname} = $objid;
2653         }
2654         $!=0; $?=0;
2655         close GITLS or failedcmd @lcmd;
2656
2657         # OK, now %want is exactly what we want for refs in @specs
2658         my @fspecs = map {
2659             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2660             "+refs/$_:".lrfetchrefs."/$_";
2661         } @specs;
2662
2663         printdebug "git_lrfetch_sane fspecs @fspecs\n";
2664
2665         my @fcmd = (@git, qw(fetch -p -n -q), $url, @fspecs);
2666         runcmd_ordryrun_local @fcmd if @fspecs;
2667
2668         if (!$supplementary) {
2669             %lrfetchrefs_f = ();
2670         }
2671         my %objgot;
2672
2673         git_for_each_ref(lrfetchrefs, sub {
2674             my ($objid,$objtype,$lrefname,$reftail) = @_;
2675             $lrfetchrefs_f{$lrefname} = $objid;
2676             $objgot{$objid} = 1;
2677         });
2678
2679         if ($supplementary) {
2680             last;
2681         }
2682
2683         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2684             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2685             if (!exists $wantr{$rrefname}) {
2686                 if ($wanted_rref->($rrefname)) {
2687                     printdebug <<END;
2688 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2689 END
2690                 } else {
2691                     print STDERR <<END
2692 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2693 END
2694                 }
2695                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2696                 delete $lrfetchrefs_f{$lrefname};
2697                 next;
2698             }
2699         }
2700         foreach my $rrefname (sort keys %wantr) {
2701             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2702             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2703             my $want = $wantr{$rrefname};
2704             next if $got eq $want;
2705             if (!defined $objgot{$want}) {
2706                 print STDERR <<END;
2707 warning: git ls-remote suggests we want $lrefname
2708 warning:  and it should refer to $want
2709 warning:  but git fetch didn't fetch that object to any relevant ref.
2710 warning:  This may be due to a race with someone updating the server.
2711 warning:  Will try again...
2712 END
2713                 next FETCH_ITERATION;
2714             }
2715             printdebug <<END;
2716 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2717 END
2718             runcmd_ordryrun_local @git, qw(update-ref -m),
2719                 "dgit fetch git fetch fixup", $lrefname, $want;
2720             $lrfetchrefs_f{$lrefname} = $want;
2721         }
2722         last;
2723     }
2724
2725     if (defined $csuite) {
2726         printdebug "git_lrfetch_sane: tidying any old suite lrfetchrefs\n";
2727         git_for_each_ref("refs/dgit-fetch/$csuite", sub {
2728             my ($objid,$objtype,$lrefname,$reftail) = @_;
2729             next if $lrfetchrefs_f{$lrefname}; # $csuite eq $distro ?
2730             runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2731         });
2732     }
2733
2734     printdebug "git_lrfetch_sane: git fetch --no-insane emulation complete\n",
2735         Dumper(\%lrfetchrefs_f);
2736 }
2737
2738 sub git_fetch_us () {
2739     # Want to fetch only what we are going to use, unless
2740     # deliberately-not-ff, in which case we must fetch everything.
2741
2742     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2743         map { "tags/$_" }
2744         (quiltmode_splitbrain
2745          ? (map { $_->('*',access_nomdistro) }
2746             \&debiantag_new, \&debiantag_maintview)
2747          : debiantags('*',access_nomdistro));
2748     push @specs, server_branch($csuite);
2749     push @specs, $rewritemap;
2750     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2751
2752     my $url = access_giturl();
2753     git_lrfetch_sane $url, 0, @specs;
2754
2755     my %here;
2756     my @tagpats = debiantags('*',access_nomdistro);
2757
2758     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2759         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2760         printdebug "currently $fullrefname=$objid\n";
2761         $here{$fullrefname} = $objid;
2762     });
2763     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2764         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2765         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2766         printdebug "offered $lref=$objid\n";
2767         if (!defined $here{$lref}) {
2768             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2769             runcmd_ordryrun_local @upd;
2770             lrfetchref_used $fullrefname;
2771         } elsif ($here{$lref} eq $objid) {
2772             lrfetchref_used $fullrefname;
2773         } else {
2774             print STDERR
2775                 "Not updating $lref from $here{$lref} to $objid.\n";
2776         }
2777     });
2778 }
2779
2780 #---------- dsc and archive handling ----------
2781
2782 sub mergeinfo_getclogp ($) {
2783     # Ensures thit $mi->{Clogp} exists and returns it
2784     my ($mi) = @_;
2785     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2786 }
2787
2788 sub mergeinfo_version ($) {
2789     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2790 }
2791
2792 sub fetch_from_archive_record_1 ($) {
2793     my ($hash) = @_;
2794     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2795             'DGIT_ARCHIVE', $hash;
2796     cmdoutput @git, qw(log -n2), $hash;
2797     # ... gives git a chance to complain if our commit is malformed
2798 }
2799
2800 sub fetch_from_archive_record_2 ($) {
2801     my ($hash) = @_;
2802     my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2803     if (act_local()) {
2804         cmdoutput @upd_cmd;
2805     } else {
2806         dryrun_report @upd_cmd;
2807     }
2808 }
2809
2810 sub parse_dsc_field_def_dsc_distro () {
2811     $dsc_distro //= cfg qw(dgit.default.old-dsc-distro
2812                            dgit.default.distro);
2813 }
2814
2815 sub parse_dsc_field ($$) {
2816     my ($dsc, $what) = @_;
2817     my $f;
2818     foreach my $field (@ourdscfield) {
2819         $f = $dsc->{$field};
2820         last if defined $f;
2821     }
2822
2823     if (!defined $f) {
2824         progress "$what: NO git hash";
2825         parse_dsc_field_def_dsc_distro();
2826     } elsif (($dsc_hash, $dsc_distro, $dsc_hint_tag, $dsc_hint_url)
2827              = $f =~ m/^(\w+)\s+($distro_re)\s+($versiontag_re)\s+(\S+)(?:\s|$)/) {
2828         progress "$what: specified git info ($dsc_distro)";
2829         $dsc_hint_tag = [ $dsc_hint_tag ];
2830     } elsif ($f =~ m/^\w+\s*$/) {
2831         $dsc_hash = $&;
2832         parse_dsc_field_def_dsc_distro();
2833         $dsc_hint_tag = [ debiantags +(getfield $dsc, 'Version'),
2834                           $dsc_distro ];
2835         progress "$what: specified git hash";
2836     } else {
2837         fail "$what: invalid Dgit info";
2838     }
2839 }
2840
2841 sub resolve_dsc_field_commit ($$) {
2842     my ($already_distro, $already_mapref) = @_;
2843
2844     return unless defined $dsc_hash;
2845
2846     my $mapref =
2847         defined $already_mapref &&
2848         ($already_distro eq $dsc_distro || !$chase_dsc_distro)
2849         ? $already_mapref : undef;
2850
2851     my $do_fetch;
2852     $do_fetch = sub {
2853         my ($what, @fetch) = @_;
2854
2855         local $idistro = $dsc_distro;
2856         my $lrf = lrfetchrefs;
2857
2858         if (!$chase_dsc_distro) {
2859             progress
2860                 "not chasing .dsc distro $dsc_distro: not fetching $what";
2861             return 0;
2862         }
2863
2864         progress
2865             ".dsc names distro $dsc_distro: fetching $what";
2866
2867         my $url = access_giturl();
2868         if (!defined $url) {
2869             defined $dsc_hint_url or fail <<END;
2870 .dsc Dgit metadata is in context of distro $dsc_distro
2871 for which we have no configured url and .dsc provides no hint
2872 END
2873             my $proto =
2874                 $dsc_hint_url =~ m#^([-+0-9a-zA-Z]+):# ? $1 :
2875                 $dsc_hint_url =~ m#^/# ? 'file' : 'bad-syntax';
2876             parse_cfg_bool "dsc-url-proto-ok", 'false',
2877                 cfg("dgit.dsc-url-proto-ok.$proto",
2878                     "dgit.default.dsc-url-proto-ok")
2879                 or fail <<END;
2880 .dsc Dgit metadata is in context of distro $dsc_distro
2881 for which we have no configured url;
2882 .dsc provides hinted url with protocol $proto which is unsafe.
2883 (can be overridden by config - consult documentation)
2884 END
2885             $url = $dsc_hint_url;
2886         }
2887
2888         git_lrfetch_sane $url, 1, @fetch;
2889
2890         return $lrf;
2891     };
2892
2893     my $rewrite_enable = do {
2894         local $idistro = $dsc_distro;
2895         access_cfg('rewrite-map-enable', 'RETURN-UNDEF');
2896     };
2897
2898     if (parse_cfg_bool 'rewrite-map-enable', 'true', $rewrite_enable) {
2899         if (!defined $mapref) {
2900             my $lrf = $do_fetch->("rewrite map", $rewritemap) or return;
2901             $mapref = $lrf.'/'.$rewritemap;
2902         }
2903         my $rewritemapdata = git_cat_file $mapref.':map';
2904         if (defined $rewritemapdata
2905             && $rewritemapdata =~ m/^$dsc_hash(?:[ \t](\w+))/m) {
2906             progress
2907                 "server's git history rewrite map contains a relevant entry!";
2908
2909             $dsc_hash = $1;
2910             if (defined $dsc_hash) {
2911                 progress "using rewritten git hash in place of .dsc value";
2912             } else {
2913                 progress "server data says .dsc hash is to be disregarded";
2914             }
2915         }
2916     }
2917
2918     if (!defined git_cat_file $dsc_hash) {
2919         my @tags = map { "tags/".$_ } @$dsc_hint_tag;
2920         my $lrf = $do_fetch->("additional commits", @tags) &&
2921             defined git_cat_file $dsc_hash
2922             or fail <<END;
2923 .dsc Dgit metadata requires commit $dsc_hash
2924 but we could not obtain that object anywhere.
2925 END
2926         foreach my $t (@tags) {
2927             my $fullrefname = $lrf.'/'.$t;
2928 #           print STDERR "CHK $t $fullrefname ".Dumper(\%lrfetchrefs_f);
2929             next unless $lrfetchrefs_f{$fullrefname};
2930             next unless is_fast_fwd "$fullrefname~0", $dsc_hash;
2931             lrfetchref_used $fullrefname;
2932         }
2933     }
2934 }
2935
2936 sub fetch_from_archive () {
2937     ensure_setup_existing_tree();
2938
2939     # Ensures that lrref() is what is actually in the archive, one way
2940     # or another, according to us - ie this client's
2941     # appropritaely-updated archive view.  Also returns the commit id.
2942     # If there is nothing in the archive, leaves lrref alone and
2943     # returns undef.  git_fetch_us must have already been called.
2944     get_archive_dsc();
2945
2946     if ($dsc) {
2947         parse_dsc_field($dsc, 'last upload to archive');
2948         resolve_dsc_field_commit access_basedistro,
2949             lrfetchrefs."/".$rewritemap
2950     } else {
2951         progress "no version available from the archive";
2952     }
2953
2954     # If the archive's .dsc has a Dgit field, there are three
2955     # relevant git commitids we need to choose between and/or merge
2956     # together:
2957     #   1. $dsc_hash: the Dgit field from the archive
2958     #   2. $lastpush_hash: the suite branch on the dgit git server
2959     #   3. $lastfetch_hash: our local tracking brach for the suite
2960     #
2961     # These may all be distinct and need not be in any fast forward
2962     # relationship:
2963     #
2964     # If the dsc was pushed to this suite, then the server suite
2965     # branch will have been updated; but it might have been pushed to
2966     # a different suite and copied by the archive.  Conversely a more
2967     # recent version may have been pushed with dgit but not appeared
2968     # in the archive (yet).
2969     #
2970     # $lastfetch_hash may be awkward because archive imports
2971     # (particularly, imports of Dgit-less .dscs) are performed only as
2972     # needed on individual clients, so different clients may perform a
2973     # different subset of them - and these imports are only made
2974     # public during push.  So $lastfetch_hash may represent a set of
2975     # imports different to a subsequent upload by a different dgit
2976     # client.
2977     #
2978     # Our approach is as follows:
2979     #
2980     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2981     # descendant of $dsc_hash, then it was pushed by a dgit user who
2982     # had based their work on $dsc_hash, so we should prefer it.
2983     # Otherwise, $dsc_hash was installed into this suite in the
2984     # archive other than by a dgit push, and (necessarily) after the
2985     # last dgit push into that suite (since a dgit push would have
2986     # been descended from the dgit server git branch); thus, in that
2987     # case, we prefer the archive's version (and produce a
2988     # pseudo-merge to overwrite the dgit server git branch).
2989     #
2990     # (If there is no Dgit field in the archive's .dsc then
2991     # generate_commit_from_dsc uses the version numbers to decide
2992     # whether the suite branch or the archive is newer.  If the suite
2993     # branch is newer it ignores the archive's .dsc; otherwise it
2994     # generates an import of the .dsc, and produces a pseudo-merge to
2995     # overwrite the suite branch with the archive contents.)
2996     #
2997     # The outcome of that part of the algorithm is the `public view',
2998     # and is same for all dgit clients: it does not depend on any
2999     # unpublished history in the local tracking branch.
3000     #
3001     # As between the public view and the local tracking branch: The
3002     # local tracking branch is only updated by dgit fetch, and
3003     # whenever dgit fetch runs it includes the public view in the
3004     # local tracking branch.  Therefore if the public view is not
3005     # descended from the local tracking branch, the local tracking
3006     # branch must contain history which was imported from the archive
3007     # but never pushed; and, its tip is now out of date.  So, we make
3008     # a pseudo-merge to overwrite the old imports and stitch the old
3009     # history in.
3010     #
3011     # Finally: we do not necessarily reify the public view (as
3012     # described above).  This is so that we do not end up stacking two
3013     # pseudo-merges.  So what we actually do is figure out the inputs
3014     # to any public view pseudo-merge and put them in @mergeinputs.
3015
3016     my @mergeinputs;
3017     # $mergeinputs[]{Commit}
3018     # $mergeinputs[]{Info}
3019     # $mergeinputs[0] is the one whose tree we use
3020     # @mergeinputs is in the order we use in the actual commit)
3021     #
3022     # Also:
3023     # $mergeinputs[]{Message} is a commit message to use
3024     # $mergeinputs[]{ReverseParents} if def specifies that parent
3025     #                                list should be in opposite order
3026     # Such an entry has no Commit or Info.  It applies only when found
3027     # in the last entry.  (This ugliness is to support making
3028     # identical imports to previous dgit versions.)
3029
3030     my $lastpush_hash = git_get_ref(lrfetchref());
3031     printdebug "previous reference hash=$lastpush_hash\n";
3032     $lastpush_mergeinput = $lastpush_hash && {
3033         Commit => $lastpush_hash,
3034         Info => "dgit suite branch on dgit git server",
3035     };
3036
3037     my $lastfetch_hash = git_get_ref(lrref());
3038     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
3039     my $lastfetch_mergeinput = $lastfetch_hash && {
3040         Commit => $lastfetch_hash,
3041         Info => "dgit client's archive history view",
3042     };
3043
3044     my $dsc_mergeinput = $dsc_hash && {
3045         Commit => $dsc_hash,
3046         Info => "Dgit field in .dsc from archive",
3047     };
3048
3049     my $cwd = getcwd();
3050     my $del_lrfetchrefs = sub {
3051         changedir $cwd;
3052         my $gur;
3053         printdebug "del_lrfetchrefs...\n";
3054         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
3055             my $objid = $lrfetchrefs_d{$fullrefname};
3056             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
3057             if (!$gur) {
3058                 $gur ||= new IO::Handle;
3059                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
3060             }
3061             printf $gur "delete %s %s\n", $fullrefname, $objid;
3062         }
3063         if ($gur) {
3064             close $gur or failedcmd "git update-ref delete lrfetchrefs";
3065         }
3066     };
3067
3068     if (defined $dsc_hash) {
3069         ensure_we_have_orig();
3070         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
3071             @mergeinputs = $dsc_mergeinput
3072         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
3073             print STDERR <<END or die $!;
3074
3075 Git commit in archive is behind the last version allegedly pushed/uploaded.
3076 Commit referred to by archive: $dsc_hash
3077 Last version pushed with dgit: $lastpush_hash
3078 $later_warning_msg
3079 END
3080             @mergeinputs = ($lastpush_mergeinput);
3081         } else {
3082             # Archive has .dsc which is not a descendant of the last dgit
3083             # push.  This can happen if the archive moves .dscs about.
3084             # Just follow its lead.
3085             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
3086                 progress "archive .dsc names newer git commit";
3087                 @mergeinputs = ($dsc_mergeinput);
3088             } else {
3089                 progress "archive .dsc names other git commit, fixing up";
3090                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
3091             }
3092         }
3093     } elsif ($dsc) {
3094         @mergeinputs = generate_commits_from_dsc();
3095         # We have just done an import.  Now, our import algorithm might
3096         # have been improved.  But even so we do not want to generate
3097         # a new different import of the same package.  So if the
3098         # version numbers are the same, just use our existing version.
3099         # If the version numbers are different, the archive has changed
3100         # (perhaps, rewound).
3101         if ($lastfetch_mergeinput &&
3102             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
3103                               (mergeinfo_version $mergeinputs[0]) )) {
3104             @mergeinputs = ($lastfetch_mergeinput);
3105         }
3106     } elsif ($lastpush_hash) {
3107         # only in git, not in the archive yet
3108         @mergeinputs = ($lastpush_mergeinput);
3109         print STDERR <<END or die $!;
3110
3111 Package not found in the archive, but has allegedly been pushed using dgit.
3112 $later_warning_msg
3113 END
3114     } else {
3115         printdebug "nothing found!\n";
3116         if (defined $skew_warning_vsn) {
3117             print STDERR <<END or die $!;
3118
3119 Warning: relevant archive skew detected.
3120 Archive allegedly contains $skew_warning_vsn
3121 But we were not able to obtain any version from the archive or git.
3122
3123 END
3124         }
3125         unshift @end, $del_lrfetchrefs;
3126         return undef;
3127     }
3128
3129     if ($lastfetch_hash &&
3130         !grep {
3131             my $h = $_->{Commit};
3132             $h and is_fast_fwd($lastfetch_hash, $h);
3133             # If true, one of the existing parents of this commit
3134             # is a descendant of the $lastfetch_hash, so we'll
3135             # be ff from that automatically.
3136         } @mergeinputs
3137         ) {
3138         # Otherwise:
3139         push @mergeinputs, $lastfetch_mergeinput;
3140     }
3141
3142     printdebug "fetch mergeinfos:\n";
3143     foreach my $mi (@mergeinputs) {
3144         if ($mi->{Info}) {
3145             printdebug " commit $mi->{Commit} $mi->{Info}\n";
3146         } else {
3147             printdebug sprintf " ReverseParents=%d Message=%s",
3148                 $mi->{ReverseParents}, $mi->{Message};
3149         }
3150     }
3151
3152     my $compat_info= pop @mergeinputs
3153         if $mergeinputs[$#mergeinputs]{Message};
3154
3155     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
3156
3157     my $hash;
3158     if (@mergeinputs > 1) {
3159         # here we go, then:
3160         my $tree_commit = $mergeinputs[0]{Commit};
3161
3162         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
3163         $tree =~ m/\n\n/;  $tree = $`;
3164         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
3165         $tree = $1;
3166
3167         # We use the changelog author of the package in question the
3168         # author of this pseudo-merge.  This is (roughly) correct if
3169         # this commit is simply representing aa non-dgit upload.
3170         # (Roughly because it does not record sponsorship - but we
3171         # don't have sponsorship info because that's in the .changes,
3172         # which isn't in the archivw.)
3173         #
3174         # But, it might be that we are representing archive history
3175         # updates (including in-archive copies).  These are not really
3176         # the responsibility of the person who created the .dsc, but
3177         # there is no-one whose name we should better use.  (The
3178         # author of the .dsc-named commit is clearly worse.)
3179
3180         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
3181         my $author = clogp_authline $useclogp;
3182         my $cversion = getfield $useclogp, 'Version';
3183
3184         my $mcf = ".git/dgit/mergecommit";
3185         open MC, ">", $mcf or die "$mcf $!";
3186         print MC <<END or die $!;
3187 tree $tree
3188 END
3189
3190         my @parents = grep { $_->{Commit} } @mergeinputs;
3191         @parents = reverse @parents if $compat_info->{ReverseParents};
3192         print MC <<END or die $! foreach @parents;
3193 parent $_->{Commit}
3194 END
3195
3196         print MC <<END or die $!;
3197 author $author
3198 committer $author
3199
3200 END
3201
3202         if (defined $compat_info->{Message}) {
3203             print MC $compat_info->{Message} or die $!;
3204         } else {
3205             print MC <<END or die $!;
3206 Record $package ($cversion) in archive suite $csuite
3207
3208 Record that
3209 END
3210             my $message_add_info = sub {
3211                 my ($mi) = (@_);
3212                 my $mversion = mergeinfo_version $mi;
3213                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
3214                     or die $!;
3215             };
3216
3217             $message_add_info->($mergeinputs[0]);
3218             print MC <<END or die $!;
3219 should be treated as descended from
3220 END
3221             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
3222         }
3223
3224         close MC or die $!;
3225         $hash = make_commit $mcf;
3226     } else {
3227         $hash = $mergeinputs[0]{Commit};
3228     }
3229     printdebug "fetch hash=$hash\n";
3230
3231     my $chkff = sub {
3232         my ($lasth, $what) = @_;
3233         return unless $lasth;
3234         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
3235     };
3236
3237     $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
3238         if $lastpush_hash;
3239     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
3240
3241     fetch_from_archive_record_1($hash);
3242
3243     if (defined $skew_warning_vsn) {
3244         mkpath '.git/dgit';
3245         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
3246         my $gotclogp = commit_getclogp($hash);
3247         my $got_vsn = getfield $gotclogp, 'Version';
3248         printdebug "SKEW CHECK GOT $got_vsn\n";
3249         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
3250             print STDERR <<END or die $!;
3251
3252 Warning: archive skew detected.  Using the available version:
3253 Archive allegedly contains    $skew_warning_vsn
3254 We were able to obtain only   $got_vsn
3255
3256 END
3257         }
3258     }
3259
3260     if ($lastfetch_hash ne $hash) {
3261         fetch_from_archive_record_2($hash);
3262     }
3263
3264     lrfetchref_used lrfetchref();
3265
3266     check_gitattrs($hash, "fetched source tree");
3267
3268     unshift @end, $del_lrfetchrefs;
3269     return $hash;
3270 }
3271
3272 sub set_local_git_config ($$) {
3273     my ($k, $v) = @_;
3274     runcmd @git, qw(config), $k, $v;
3275 }
3276
3277 sub setup_mergechangelogs (;$) {
3278     my ($always) = @_;
3279     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3280
3281     my $driver = 'dpkg-mergechangelogs';
3282     my $cb = "merge.$driver";
3283     my $attrs = '.git/info/attributes';
3284     ensuredir '.git/info';
3285
3286     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3287     if (!open ATTRS, "<", $attrs) {
3288         $!==ENOENT or die "$attrs: $!";
3289     } else {
3290         while (<ATTRS>) {
3291             chomp;
3292             next if m{^debian/changelog\s};
3293             print NATTRS $_, "\n" or die $!;
3294         }
3295         ATTRS->error and die $!;
3296         close ATTRS;
3297     }
3298     print NATTRS "debian/changelog merge=$driver\n" or die $!;
3299     close NATTRS;
3300
3301     set_local_git_config "$cb.name", 'debian/changelog merge driver';
3302     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3303
3304     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3305 }
3306
3307 sub setup_useremail (;$) {
3308     my ($always) = @_;
3309     return unless $always || access_cfg_bool(1, 'setup-useremail');
3310
3311     my $setup = sub {
3312         my ($k, $envvar) = @_;
3313         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3314         return unless defined $v;
3315         set_local_git_config "user.$k", $v;
3316     };
3317
3318     $setup->('email', 'DEBEMAIL');
3319     $setup->('name', 'DEBFULLNAME');
3320 }
3321
3322 sub ensure_setup_existing_tree () {
3323     my $k = "remote.$remotename.skipdefaultupdate";
3324     my $c = git_get_config $k;
3325     return if defined $c;
3326     set_local_git_config $k, 'true';
3327 }
3328
3329 sub open_gitattrs () {
3330     my $gai = new IO::File ".git/info/attributes"
3331         or $!==ENOENT
3332         or die "open .git/info/attributes: $!";
3333     return $gai;
3334 }
3335
3336 sub is_gitattrs_setup () {
3337     my $gai = open_gitattrs();
3338     return 0 unless $gai;
3339     while (<$gai>) {
3340         return 1 if m{^\[attr\]dgit-defuse-attrs\s};
3341     }
3342     $gai->error and die $!;
3343     return 0;
3344 }    
3345
3346 sub setup_gitattrs (;$) {
3347     my ($always) = @_;
3348     return unless $always || access_cfg_bool(1, 'setup-gitattributes');
3349
3350     if (is_gitattrs_setup()) {
3351         progress <<END;
3352 [attr]dgit-defuse-attrs already found in .git/info/attributes
3353  not doing further gitattributes setup
3354 END
3355         return;
3356     }
3357     my $af = ".git/info/attributes";
3358     open GAO, "> $af.new" or die $!;
3359     print GAO <<END or die $!;
3360 *       dgit-defuse-attrs
3361 [attr]dgit-defuse-attrs -text -eol -crlf -ident -filter
3362 # ^ see GITATTRIBUTES in dgit(7) and dgit setup-new-tree in dgit(1)
3363 END
3364     my $gai = open_gitattrs();
3365     if ($gai) {
3366         while (<$gai>) {
3367             chomp;
3368             print GAO $_, "\n" or die $!;
3369         }
3370         $gai->error and die $!;
3371     }
3372     close GAO or die $!;
3373     rename "$af.new", "$af" or die "install $af: $!";
3374 }
3375
3376 sub setup_new_tree () {
3377     setup_mergechangelogs();
3378     setup_useremail();
3379     setup_gitattrs();
3380 }
3381
3382 sub check_gitattrs ($$) {
3383     my ($treeish, $what) = @_;
3384
3385     return if is_gitattrs_setup;
3386
3387     local $/="\0";
3388     my @cmd = (@git, qw(ls-tree -lrz --), "${treeish}:");
3389     debugcmd "|",@cmd;
3390     my $gafl = new IO::File;
3391     open $gafl, "-|", @cmd or die $!;
3392     while (<$gafl>) {
3393         chomp or die;
3394         s/^\d+\s+\w+\s+\w+\s+(\d+)\t// or die;
3395         next if $1 == 0;
3396         next unless m{(?:^|/)\.gitattributes$};
3397
3398         # oh dear, found one
3399         print STDERR <<END;
3400 dgit: warning: $what contains .gitattributes
3401 dgit: .gitattributes have not been defused.  Recommended: dgit setup-new-tree.
3402 END
3403         close $gafl;
3404         return;
3405     }
3406     # tree contains no .gitattributes files
3407     $?=0; $!=0; close $gafl or failedcmd @cmd;
3408 }
3409
3410
3411 sub multisuite_suite_child ($$$) {
3412     my ($tsuite, $merginputs, $fn) = @_;
3413     # in child, sets things up, calls $fn->(), and returns undef
3414     # in parent, returns canonical suite name for $tsuite
3415     my $canonsuitefh = IO::File::new_tmpfile;
3416     my $pid = fork // die $!;
3417     if (!$pid) {
3418         forkcheck_setup();
3419         $isuite = $tsuite;
3420         $us .= " [$isuite]";
3421         $debugprefix .= " ";
3422         progress "fetching $tsuite...";
3423         canonicalise_suite();
3424         print $canonsuitefh $csuite, "\n" or die $!;
3425         close $canonsuitefh or die $!;
3426         $fn->();
3427         return undef;
3428     }
3429     waitpid $pid,0 == $pid or die $!;
3430     fail "failed to obtain $tsuite: ".waitstatusmsg() if $? && $?!=256*4;
3431     seek $canonsuitefh,0,0 or die $!;
3432     local $csuite = <$canonsuitefh>;
3433     die $! unless defined $csuite && chomp $csuite;
3434     if ($? == 256*4) {
3435         printdebug "multisuite $tsuite missing\n";
3436         return $csuite;
3437     }
3438     printdebug "multisuite $tsuite ok (canon=$csuite)\n";
3439     push @$merginputs, {
3440         Ref => lrref,
3441         Info => $csuite,
3442     };
3443     return $csuite;
3444 }
3445
3446 sub fork_for_multisuite ($) {
3447     my ($before_fetch_merge) = @_;
3448     # if nothing unusual, just returns ''
3449     #
3450     # if multisuite:
3451     # returns 0 to caller in child, to do first of the specified suites
3452     # in child, $csuite is not yet set
3453     #
3454     # returns 1 to caller in parent, to finish up anything needed after
3455     # in parent, $csuite is set to canonicalised portmanteau
3456
3457     my $org_isuite = $isuite;
3458     my @suites = split /\,/, $isuite;
3459     return '' unless @suites > 1;
3460     printdebug "fork_for_multisuite: @suites\n";
3461
3462     my @mergeinputs;
3463
3464     my $cbasesuite = multisuite_suite_child($suites[0], \@mergeinputs,
3465                                             sub { });
3466     return 0 unless defined $cbasesuite;
3467
3468     fail "package $package missing in (base suite) $cbasesuite"
3469         unless @mergeinputs;
3470
3471     my @csuites = ($cbasesuite);
3472
3473     $before_fetch_merge->();
3474
3475     foreach my $tsuite (@suites[1..$#suites]) {
3476         my $csubsuite = multisuite_suite_child($tsuite, \@mergeinputs,
3477                                                sub {
3478             @end = ();
3479             fetch();
3480             exit 0;
3481         });
3482         # xxx collecte the ref here
3483
3484         $csubsuite =~ s/^\Q$cbasesuite\E-/-/;
3485         push @csuites, $csubsuite;
3486     }
3487
3488     foreach my $mi (@mergeinputs) {
3489         my $ref = git_get_ref $mi->{Ref};
3490         die "$mi->{Ref} ?" unless length $ref;
3491         $mi->{Commit} = $ref;
3492     }
3493
3494     $csuite = join ",", @csuites;
3495
3496     my $previous = git_get_ref lrref;
3497     if ($previous) {
3498         unshift @mergeinputs, {
3499             Commit => $previous,
3500             Info => "local combined tracking branch",
3501             Warning =>
3502  "archive seems to have rewound: local tracking branch is ahead!",
3503         };
3504     }
3505
3506     foreach my $ix (0..$#mergeinputs) {
3507         $mergeinputs[$ix]{Index} = $ix;
3508     }
3509
3510     @mergeinputs = sort {
3511         -version_compare(mergeinfo_version $a,
3512                          mergeinfo_version $b) # highest version first
3513             or
3514         $a->{Index} <=> $b->{Index}; # earliest in spec first
3515     } @mergeinputs;
3516
3517     my @needed;
3518
3519   NEEDED:
3520     foreach my $mi (@mergeinputs) {
3521         printdebug "multisuite merge check $mi->{Info}\n";
3522         foreach my $previous (@needed) {
3523             next unless is_fast_fwd $mi->{Commit}, $previous->{Commit};
3524             printdebug "multisuite merge un-needed $previous->{Info}\n";
3525             next NEEDED;
3526         }
3527         push @needed, $mi;
3528         printdebug "multisuite merge this-needed\n";
3529         $mi->{Character} = '+';
3530     }
3531
3532     $needed[0]{Character} = '*';
3533
3534     my $output = $needed[0]{Commit};
3535
3536     if (@needed > 1) {
3537         printdebug "multisuite merge nontrivial\n";
3538         my $tree = cmdoutput qw(git rev-parse), $needed[0]{Commit}.':';
3539
3540         my $commit = "tree $tree\n";
3541         my $msg = "Combine archive branches $csuite [dgit]\n\n".
3542             "Input branches:\n";
3543
3544         foreach my $mi (sort { $a->{Index} <=> $b->{Index} } @mergeinputs) {
3545             printdebug "multisuite merge include $mi->{Info}\n";
3546             $mi->{Character} //= ' ';
3547             $commit .= "parent $mi->{Commit}\n";
3548             $msg .= sprintf " %s  %-25s %s\n",
3549                 $mi->{Character},
3550                 (mergeinfo_version $mi),
3551                 $mi->{Info};
3552         }
3553         my $authline = clogp_authline mergeinfo_getclogp $needed[0];
3554         $msg .= "\nKey\n".
3555             " * marks the highest version branch, which choose to use\n".
3556             " + marks each branch which was not already an ancestor\n\n".
3557             "[dgit multi-suite $csuite]\n";
3558         $commit .=
3559             "author $authline\n".
3560             "committer $authline\n\n";
3561         $output = make_commit_text $commit.$msg;
3562         printdebug "multisuite merge generated $output\n";
3563     }
3564
3565     fetch_from_archive_record_1($output);
3566     fetch_from_archive_record_2($output);
3567
3568     progress "calculated combined tracking suite $csuite";
3569
3570     return 1;
3571 }
3572
3573 sub clone_set_head () {
3574     open H, "> .git/HEAD" or die $!;
3575     print H "ref: ".lref()."\n" or die $!;
3576     close H or die $!;
3577 }
3578 sub clone_finish ($) {
3579     my ($dstdir) = @_;
3580     runcmd @git, qw(reset --hard), lrref();
3581     runcmd qw(bash -ec), <<'END';
3582         set -o pipefail
3583         git ls-tree -r --name-only -z HEAD | \
3584         xargs -0r touch -h -r . --
3585 END
3586     printdone "ready for work in $dstdir";
3587 }
3588
3589 sub clone ($) {
3590     my ($dstdir) = @_;
3591     badusage "dry run makes no sense with clone" unless act_local();
3592
3593     my $multi_fetched = fork_for_multisuite(sub {
3594         printdebug "multi clone before fetch merge\n";
3595         changedir $dstdir;
3596     });
3597     if ($multi_fetched) {
3598         printdebug "multi clone after fetch merge\n";
3599         clone_set_head();
3600         clone_finish($dstdir);
3601         exit 0;
3602     }
3603     printdebug "clone main body\n";
3604
3605     canonicalise_suite();
3606     my $hasgit = check_for_git();
3607     mkdir $dstdir or fail "create \`$dstdir': $!";
3608     changedir $dstdir;
3609     runcmd @git, qw(init -q);
3610     setup_new_tree();
3611     clone_set_head();
3612     my $giturl = access_giturl(1);
3613     if (defined $giturl) {
3614         runcmd @git, qw(remote add), 'origin', $giturl;
3615     }
3616     if ($hasgit) {
3617         progress "fetching existing git history";
3618         git_fetch_us();
3619         runcmd_ordryrun_local @git, qw(fetch origin);
3620     } else {
3621         progress "starting new git history";
3622     }
3623     fetch_from_archive() or no_such_package;
3624     my $vcsgiturl = $dsc->{'Vcs-Git'};
3625     if (length $vcsgiturl) {
3626         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3627         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3628     }
3629     clone_finish($dstdir);
3630 }
3631
3632 sub fetch () {
3633     canonicalise_suite();
3634     if (check_for_git()) {
3635         git_fetch_us();
3636     }
3637     fetch_from_archive() or no_such_package();
3638     printdone "fetched into ".lrref();
3639 }
3640
3641 sub pull () {
3642     my $multi_fetched = fork_for_multisuite(sub { });
3643     fetch() unless $multi_fetched; # parent
3644     return if $multi_fetched eq '0'; # child
3645     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3646         lrref();
3647     printdone "fetched to ".lrref()." and merged into HEAD";
3648 }
3649
3650 sub check_not_dirty () {
3651     foreach my $f (qw(local-options local-patch-header)) {
3652         if (stat_exists "debian/source/$f") {
3653             fail "git tree contains debian/source/$f";
3654         }
3655     }
3656
3657     return if $ignoredirty;
3658
3659     my @cmd = (@git, qw(diff --quiet HEAD));
3660     debugcmd "+",@cmd;
3661     $!=0; $?=-1; system @cmd;
3662     return if !$?;
3663     if ($?==256) {
3664         fail "working tree is dirty (does not match HEAD)";
3665     } else {
3666         failedcmd @cmd;
3667     }
3668 }
3669
3670 sub commit_admin ($) {
3671     my ($m) = @_;
3672     progress "$m";
3673     runcmd_ordryrun_local @git, qw(commit -m), $m;
3674 }
3675
3676 sub commit_quilty_patch () {
3677     my $output = cmdoutput @git, qw(status --porcelain);
3678     my %adds;
3679     foreach my $l (split /\n/, $output) {
3680         next unless $l =~ m/\S/;
3681         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3682             $adds{$1}++;
3683         }
3684     }
3685     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3686     if (!%adds) {
3687         progress "nothing quilty to commit, ok.";
3688         return;
3689     }
3690     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3691     runcmd_ordryrun_local @git, qw(add -f), @adds;
3692     commit_admin <<END
3693 Commit Debian 3.0 (quilt) metadata
3694
3695 [dgit ($our_version) quilt-fixup]
3696 END
3697 }
3698
3699 sub get_source_format () {
3700     my %options;
3701     if (open F, "debian/source/options") {
3702         while (<F>) {
3703             next if m/^\s*\#/;
3704             next unless m/\S/;
3705             s/\s+$//; # ignore missing final newline
3706             if (m/\s*\#\s*/) {
3707                 my ($k, $v) = ($`, $'); #');
3708                 $v =~ s/^"(.*)"$/$1/;
3709                 $options{$k} = $v;
3710             } else {
3711                 $options{$_} = 1;
3712             }
3713         }
3714         F->error and die $!;
3715         close F;
3716     } else {
3717         die $! unless $!==&ENOENT;
3718     }
3719
3720     if (!open F, "debian/source/format") {
3721         die $! unless $!==&ENOENT;
3722         return '';
3723     }
3724     $_ = <F>;
3725     F->error and die $!;