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