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