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