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