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