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