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