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