chiark / gitweb /
Split brain: Provide --gbp= and --gbp:
[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
38 use Debian::Dgit;
39
40 our $our_version = 'UNRELEASED'; ###substituted###
41
42 our @rpushprotovsn_support = qw(3 2);
43 our $protovsn;
44
45 our $isuite = 'unstable';
46 our $idistro;
47 our $package;
48 our @ropts;
49
50 our $sign = 1;
51 our $dryrun_level = 0;
52 our $changesfile;
53 our $buildproductsdir = '..';
54 our $new_package = 0;
55 our $ignoredirty = 0;
56 our $rmonerror = 1;
57 our @deliberatelies;
58 our %previously;
59 our $existing_package = 'dpkg';
60 our $cleanmode;
61 our $changes_since_version;
62 our $rmchanges;
63 our $quilt_mode;
64 our $quilt_modes_re = 'linear|smash|auto|nofix|nocheck|gbp|unapplied';
65 our $we_are_responder;
66 our $initiator_tempdir;
67 our $patches_applied_dirtily = 00;
68
69 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
70
71 our $suite_re = '[-+.0-9a-z]+';
72 our $cleanmode_re = 'dpkg-source(?:-d)?|git|git-ff|check|none';
73
74 our $git_authline_re = '^([^<>]+) \<(\S+)\> (\d+ [-+]\d+)$';
75 our $splitbraincache = 'dgit-intern/quilt-cache';
76
77 our (@git) = qw(git);
78 our (@dget) = qw(dget);
79 our (@curl) = qw(curl -f);
80 our (@dput) = qw(dput);
81 our (@debsign) = qw(debsign);
82 our (@gpg) = qw(gpg);
83 our (@sbuild) = qw(sbuild);
84 our (@ssh) = 'ssh';
85 our (@dgit) = qw(dgit);
86 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
87 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
88 our (@dpkggenchanges) = qw(dpkg-genchanges);
89 our (@mergechanges) = qw(mergechanges -f);
90 our (@gbp) = qw(gbp);
91 our (@changesopts) = ('');
92
93 our %opts_opt_map = ('dget' => \@dget, # accept for compatibility
94                      'curl' => \@curl,
95                      'dput' => \@dput,
96                      'debsign' => \@debsign,
97                      'gpg' => \@gpg,
98                      'sbuild' => \@sbuild,
99                      'ssh' => \@ssh,
100                      'dgit' => \@dgit,
101                      'git' => \@git,
102                      'dpkg-source' => \@dpkgsource,
103                      'dpkg-buildpackage' => \@dpkgbuildpackage,
104                      'dpkg-genchanges' => \@dpkggenchanges,
105                      'gbp' => \@gbp,
106                      'ch' => \@changesopts,
107                      'mergechanges' => \@mergechanges);
108
109 our %opts_opt_cmdonly = ('gpg' => 1, 'git' => 1);
110 our %opts_cfg_insertpos = map {
111     $_,
112     scalar @{ $opts_opt_map{$_} }
113 } keys %opts_opt_map;
114
115 sub finalise_opts_opts();
116
117 our $keyid;
118
119 autoflush STDOUT 1;
120
121 our $supplementary_message = '';
122 our $need_split_build_invocation = 0;
123 our $split_brain = 0;
124
125 END {
126     local ($@, $?);
127     print STDERR "! $_\n" foreach $supplementary_message =~ m/^.+$/mg;
128 }
129
130 our $remotename = 'dgit';
131 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
132 our $csuite;
133 our $instead_distro;
134
135 sub lbranch () { return "$branchprefix/$csuite"; }
136 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
137 sub lref () { return "refs/heads/".lbranch(); }
138 sub lrref () { return "refs/remotes/$remotename/".server_branch($csuite); }
139 sub rrref () { return server_ref($csuite); }
140
141 sub lrfetchrefs () { return "refs/dgit-fetch/$csuite"; }
142
143 sub stripepoch ($) {
144     my ($vsn) = @_;
145     $vsn =~ s/^\d+\://;
146     return $vsn;
147 }
148
149 sub srcfn ($$) {
150     my ($vsn,$sfx) = @_;
151     return "${package}_".(stripepoch $vsn).$sfx
152 }
153
154 sub dscfn ($) {
155     my ($vsn) = @_;
156     return srcfn($vsn,".dsc");
157 }
158
159 sub changespat ($;$) {
160     my ($vsn, $arch) = @_;
161     return "${package}_".(stripepoch $vsn)."_".($arch//'*').".changes";
162 }
163
164 our $us = 'dgit';
165 initdebug('');
166
167 our @end;
168 END { 
169     local ($?);
170     foreach my $f (@end) {
171         eval { $f->(); };
172         print STDERR "$us: cleanup: $@" if length $@;
173     }
174 };
175
176 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
177
178 sub no_such_package () {
179     print STDERR "$us: package $package does not exist in suite $isuite\n";
180     exit 4;
181 }
182
183 sub fetchspec () {
184     local $csuite = '*';
185     return  "+".rrref().":".lrref();
186 }
187
188 sub changedir ($) {
189     my ($newdir) = @_;
190     printdebug "CD $newdir\n";
191     chdir $newdir or die "chdir: $newdir: $!";
192 }
193
194 sub deliberately ($) {
195     my ($enquiry) = @_;
196     return !!grep { $_ eq "--deliberately-$enquiry" } @deliberatelies;
197 }
198
199 sub deliberately_not_fast_forward () {
200     foreach (qw(not-fast-forward fresh-repo)) {
201         return 1 if deliberately($_) || deliberately("TEST-dgit-only-$_");
202     }
203 }
204
205 sub quiltmode_splitbrain () {
206     $quilt_mode =~ m/gbp|dpm|unapplied/;
207 }
208
209 #---------- remote protocol support, common ----------
210
211 # remote push initiator/responder protocol:
212 #  $ dgit remote-push-build-host <n-rargs> <rargs>... <push-args>...
213 #  where <rargs> is <push-host-dir> <supported-proto-vsn>,... ...
214 #  < dgit-remote-push-ready <actual-proto-vsn>
215 #
216 #  > file parsed-changelog
217 #  [indicates that output of dpkg-parsechangelog follows]
218 #  > data-block NBYTES
219 #  > [NBYTES bytes of data (no newline)]
220 #  [maybe some more blocks]
221 #  > data-end
222 #
223 #  > file dsc
224 #  [etc]
225 #
226 #  > file changes
227 #  [etc]
228 #
229 #  > param head HEAD
230 #
231 #  > want signed-tag
232 #  [indicates that signed tag is wanted]
233 #  < data-block NBYTES
234 #  < [NBYTES bytes of data (no newline)]
235 #  [maybe some more blocks]
236 #  < data-end
237 #  < files-end
238 #
239 #  > want signed-dsc-changes
240 #  < data-block NBYTES    [transfer of signed dsc]
241 #  [etc]
242 #  < data-block NBYTES    [transfer of signed changes]
243 #  [etc]
244 #  < files-end
245 #
246 #  > complete
247
248 our $i_child_pid;
249
250 sub i_child_report () {
251     # Sees if our child has died, and reap it if so.  Returns a string
252     # describing how it died if it failed, or undef otherwise.
253     return undef unless $i_child_pid;
254     my $got = waitpid $i_child_pid, WNOHANG;
255     return undef if $got <= 0;
256     die unless $got == $i_child_pid;
257     $i_child_pid = undef;
258     return undef unless $?;
259     return "build host child ".waitstatusmsg();
260 }
261
262 sub badproto ($$) {
263     my ($fh, $m) = @_;
264     fail "connection lost: $!" if $fh->error;
265     fail "protocol violation; $m not expected";
266 }
267
268 sub badproto_badread ($$) {
269     my ($fh, $wh) = @_;
270     fail "connection lost: $!" if $!;
271     my $report = i_child_report();
272     fail $report if defined $report;
273     badproto $fh, "eof (reading $wh)";
274 }
275
276 sub protocol_expect (&$) {
277     my ($match, $fh) = @_;
278     local $_;
279     $_ = <$fh>;
280     defined && chomp or badproto_badread $fh, "protocol message";
281     if (wantarray) {
282         my @r = &$match;
283         return @r if @r;
284     } else {
285         my $r = &$match;
286         return $r if $r;
287     }
288     badproto $fh, "\`$_'";
289 }
290
291 sub protocol_send_file ($$) {
292     my ($fh, $ourfn) = @_;
293     open PF, "<", $ourfn or die "$ourfn: $!";
294     for (;;) {
295         my $d;
296         my $got = read PF, $d, 65536;
297         die "$ourfn: $!" unless defined $got;
298         last if !$got;
299         print $fh "data-block ".length($d)."\n" or die $!;
300         print $fh $d or die $!;
301     }
302     PF->error and die "$ourfn $!";
303     print $fh "data-end\n" or die $!;
304     close PF;
305 }
306
307 sub protocol_read_bytes ($$) {
308     my ($fh, $nbytes) = @_;
309     $nbytes =~ m/^[1-9]\d{0,5}$|^0$/ or badproto \*RO, "bad byte count";
310     my $d;
311     my $got = read $fh, $d, $nbytes;
312     $got==$nbytes or badproto_badread $fh, "data block";
313     return $d;
314 }
315
316 sub protocol_receive_file ($$) {
317     my ($fh, $ourfn) = @_;
318     printdebug "() $ourfn\n";
319     open PF, ">", $ourfn or die "$ourfn: $!";
320     for (;;) {
321         my ($y,$l) = protocol_expect {
322             m/^data-block (.*)$/ ? (1,$1) :
323             m/^data-end$/ ? (0,) :
324             ();
325         } $fh;
326         last unless $y;
327         my $d = protocol_read_bytes $fh, $l;
328         print PF $d or die $!;
329     }
330     close PF or die $!;
331 }
332
333 #---------- remote protocol support, responder ----------
334
335 sub responder_send_command ($) {
336     my ($command) = @_;
337     return unless $we_are_responder;
338     # called even without $we_are_responder
339     printdebug ">> $command\n";
340     print PO $command, "\n" or die $!;
341 }    
342
343 sub responder_send_file ($$) {
344     my ($keyword, $ourfn) = @_;
345     return unless $we_are_responder;
346     printdebug "]] $keyword $ourfn\n";
347     responder_send_command "file $keyword";
348     protocol_send_file \*PO, $ourfn;
349 }
350
351 sub responder_receive_files ($@) {
352     my ($keyword, @ourfns) = @_;
353     die unless $we_are_responder;
354     printdebug "[[ $keyword @ourfns\n";
355     responder_send_command "want $keyword";
356     foreach my $fn (@ourfns) {
357         protocol_receive_file \*PI, $fn;
358     }
359     printdebug "[[\$\n";
360     protocol_expect { m/^files-end$/ } \*PI;
361 }
362
363 #---------- remote protocol support, initiator ----------
364
365 sub initiator_expect (&) {
366     my ($match) = @_;
367     protocol_expect { &$match } \*RO;
368 }
369
370 #---------- end remote code ----------
371
372 sub progress {
373     if ($we_are_responder) {
374         my $m = join '', @_;
375         responder_send_command "progress ".length($m) or die $!;
376         print PO $m or die $!;
377     } else {
378         print @_, "\n";
379     }
380 }
381
382 our $ua;
383
384 sub url_get {
385     if (!$ua) {
386         $ua = LWP::UserAgent->new();
387         $ua->env_proxy;
388     }
389     my $what = $_[$#_];
390     progress "downloading $what...";
391     my $r = $ua->get(@_) or die $!;
392     return undef if $r->code == 404;
393     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
394     return $r->decoded_content(charset => 'none');
395 }
396
397 our ($dscdata,$dscurl,$dsc,$dsc_checked,$skew_warning_vsn);
398
399 sub runcmd {
400     debugcmd "+",@_;
401     $!=0; $?=0;
402     failedcmd @_ if system @_;
403 }
404
405 sub act_local () { return $dryrun_level <= 1; }
406 sub act_scary () { return !$dryrun_level; }
407
408 sub printdone {
409     if (!$dryrun_level) {
410         progress "dgit ok: @_";
411     } else {
412         progress "would be ok: @_ (but dry run only)";
413     }
414 }
415
416 sub dryrun_report {
417     printcmd(\*STDERR,$debugprefix."#",@_);
418 }
419
420 sub runcmd_ordryrun {
421     if (act_scary()) {
422         runcmd @_;
423     } else {
424         dryrun_report @_;
425     }
426 }
427
428 sub runcmd_ordryrun_local {
429     if (act_local()) {
430         runcmd @_;
431     } else {
432         dryrun_report @_;
433     }
434 }
435
436 sub shell_cmd {
437     my ($first_shell, @cmd) = @_;
438     return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
439 }
440
441 our $helpmsg = <<END;
442 main usages:
443   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
444   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
445   dgit [dgit-opts] build [dpkg-buildpackage-opts]
446   dgit [dgit-opts] sbuild [sbuild-opts]
447   dgit [dgit-opts] push [dgit-opts] [suite]
448   dgit [dgit-opts] rpush build-host:build-dir ...
449 important dgit options:
450   -k<keyid>           sign tag and package with <keyid> instead of default
451   --dry-run -n        do not change anything, but go through the motions
452   --damp-run -L       like --dry-run but make local changes, without signing
453   --new -N            allow introducing a new package
454   --debug -D          increase debug level
455   -c<name>=<value>    set git config option (used directly by dgit too)
456 END
457
458 our $later_warning_msg = <<END;
459 Perhaps the upload is stuck in incoming.  Using the version from git.
460 END
461
462 sub badusage {
463     print STDERR "$us: @_\n", $helpmsg or die $!;
464     exit 8;
465 }
466
467 sub nextarg {
468     @ARGV or badusage "too few arguments";
469     return scalar shift @ARGV;
470 }
471
472 sub cmd_help () {
473     print $helpmsg or die $!;
474     exit 0;
475 }
476
477 our $td = $ENV{DGIT_TEST_DUMMY_DIR} || "DGIT_TEST_DUMMY_DIR-unset";
478
479 our %defcfg = ('dgit.default.distro' => 'debian',
480                'dgit.default.username' => '',
481                'dgit.default.archive-query-default-component' => 'main',
482                'dgit.default.ssh' => 'ssh',
483                'dgit.default.archive-query' => 'madison:',
484                'dgit.default.sshpsql-dbname' => 'service=projectb',
485                'dgit-distro.debian.archive-query' => 'ftpmasterapi:',
486                'dgit-distro.debian.git-check' => 'url',
487                'dgit-distro.debian.git-check-suffix' => '/info/refs',
488                'dgit-distro.debian.new-private-pushers' => 't',
489                'dgit-distro.debian/push.git-url' => '',
490                'dgit-distro.debian/push.git-host' => 'push.dgit.debian.org',
491                'dgit-distro.debian/push.git-user-force' => 'dgit',
492                'dgit-distro.debian/push.git-proto' => 'git+ssh://',
493                'dgit-distro.debian/push.git-path' => '/dgit/debian/repos',
494                'dgit-distro.debian/push.git-create' => 'true',
495                'dgit-distro.debian/push.git-check' => 'ssh-cmd',
496  'dgit-distro.debian.archive-query-url', 'https://api.ftp-master.debian.org/',
497 # 'dgit-distro.debian.archive-query-tls-key',
498 #    '/etc/ssl/certs/%HOST%.pem:/etc/dgit/%HOST%.pem',
499 # ^ this does not work because curl is broken nowadays
500 # Fixing #790093 properly will involve providing providing the key
501 # in some pacagke and maybe updating these paths.
502 #
503 # 'dgit-distro.debian.archive-query-tls-curl-args',
504 #   '--ca-path=/etc/ssl/ca-debian',
505 # ^ this is a workaround but works (only) on DSA-administered machines
506                'dgit-distro.debian.git-url' => 'https://git.dgit.debian.org',
507                'dgit-distro.debian.git-url-suffix' => '',
508                'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
509                'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/',
510  'dgit-distro.debian.backports-quirk' => '(squeeze)-backports*',
511  'dgit-distro.debian-backports.mirror' => 'http://backports.debian.org/debian-backports/',
512                'dgit-distro.ubuntu.git-check' => 'false',
513  'dgit-distro.ubuntu.mirror' => 'http://archive.ubuntu.com/ubuntu',
514                'dgit-distro.test-dummy.ssh' => "$td/ssh",
515                'dgit-distro.test-dummy.username' => "alice",
516                'dgit-distro.test-dummy.git-check' => "ssh-cmd",
517                'dgit-distro.test-dummy.git-create' => "ssh-cmd",
518                'dgit-distro.test-dummy.git-url' => "$td/git",
519                'dgit-distro.test-dummy.git-host' => "git",
520                'dgit-distro.test-dummy.git-path' => "$td/git",
521                'dgit-distro.test-dummy.archive-query' => "ftpmasterapi:",
522                'dgit-distro.test-dummy.archive-query-url' => "file://$td/aq/",
523                'dgit-distro.test-dummy.mirror' => "file://$td/mirror/",
524                'dgit-distro.test-dummy.upload-host' => 'test-dummy',
525                );
526
527 our %gitcfg;
528
529 sub git_slurp_config () {
530     local ($debuglevel) = $debuglevel-2;
531     local $/="\0";
532
533     my @cmd = (@git, qw(config -z --get-regexp .*));
534     debugcmd "|",@cmd;
535
536     open GITS, "-|", @cmd or failedcmd @cmd;
537     while (<GITS>) {
538         chomp or die;
539         printdebug "=> ", (messagequote $_), "\n";
540         m/\n/ or die "$_ ?";
541         push @{ $gitcfg{$`} }, $'; #';
542     }
543     $!=0; $?=0;
544     close GITS
545         or ($!==0 && $?==256)
546         or failedcmd @cmd;
547 }
548
549 sub git_get_config ($) {
550     my ($c) = @_;
551     my $l = $gitcfg{$c};
552     printdebug"C $c ".(defined $l ? messagequote "'$l'" : "undef")."\n"
553         if $debuglevel >= 4;
554     $l or return undef;
555     @$l==1 or badcfg "multiple values for $c" if @$l > 1;
556     return $l->[0];
557 }
558
559 sub cfg {
560     foreach my $c (@_) {
561         return undef if $c =~ /RETURN-UNDEF/;
562         my $v = git_get_config($c);
563         return $v if defined $v;
564         my $dv = $defcfg{$c};
565         return $dv if defined $dv;
566     }
567     badcfg "need value for one of: @_\n".
568         "$us: distro or suite appears not to be (properly) supported";
569 }
570
571 sub access_basedistro () {
572     if (defined $idistro) {
573         return $idistro;
574     } else {    
575         return cfg("dgit-suite.$isuite.distro",
576                    "dgit.default.distro");
577     }
578 }
579
580 sub access_quirk () {
581     # returns (quirk name, distro to use instead or undef, quirk-specific info)
582     my $basedistro = access_basedistro();
583     my $backports_quirk = cfg("dgit-distro.$basedistro.backports-quirk",
584                               'RETURN-UNDEF');
585     if (defined $backports_quirk) {
586         my $re = $backports_quirk;
587         $re =~ s/[^-0-9a-z_\%*()]/\\$&/ig;
588         $re =~ s/\*/.*/g;
589         $re =~ s/\%/([-0-9a-z_]+)/
590             or $re =~ m/[()]/ or badcfg "backports-quirk needs \% or ( )";
591         if ($isuite =~ m/^$re$/) {
592             return ('backports',"$basedistro-backports",$1);
593         }
594     }
595     return ('none',undef);
596 }
597
598 our $access_forpush;
599
600 sub parse_cfg_bool ($$$) {
601     my ($what,$def,$v) = @_;
602     $v //= $def;
603     return
604         $v =~ m/^[ty1]/ ? 1 :
605         $v =~ m/^[fn0]/ ? 0 :
606         badcfg "$what needs t (true, y, 1) or f (false, n, 0) not \`$v'";
607 }       
608
609 sub access_forpush_config () {
610     my $d = access_basedistro();
611
612     return 1 if
613         $new_package &&
614         parse_cfg_bool('new-private-pushers', 0,
615                        cfg("dgit-distro.$d.new-private-pushers",
616                            'RETURN-UNDEF'));
617
618     my $v = cfg("dgit-distro.$d.readonly", 'RETURN-UNDEF');
619     $v //= 'a';
620     return
621         $v =~ m/^[ty1]/ ? 0 : # force readonly,    forpush = 0
622         $v =~ m/^[fn0]/ ? 1 : # force nonreadonly, forpush = 1
623         $v =~ m/^[a]/  ? '' : # auto,              forpush = ''
624         badcfg "readonly needs t (true, y, 1) or f (false, n, 0) or a (auto)";
625 }
626
627 sub access_forpush () {
628     $access_forpush //= access_forpush_config();
629     return $access_forpush;
630 }
631
632 sub pushing () {
633     die "$access_forpush ?" if ($access_forpush // 1) ne 1;
634     badcfg "pushing but distro is configured readonly"
635         if access_forpush_config() eq '0';
636     $access_forpush = 1;
637     $supplementary_message = <<'END' unless $we_are_responder;
638 Push failed, before we got started.
639 You can retry the push, after fixing the problem, if you like.
640 END
641     finalise_opts_opts();
642 }
643
644 sub notpushing () {
645     finalise_opts_opts();
646 }
647
648 sub supplementary_message ($) {
649     my ($msg) = @_;
650     if (!$we_are_responder) {
651         $supplementary_message = $msg;
652         return;
653     } elsif ($protovsn >= 3) {
654         responder_send_command "supplementary-message ".length($msg)
655             or die $!;
656         print PO $msg or die $!;
657     }
658 }
659
660 sub access_distros () {
661     # Returns list of distros to try, in order
662     #
663     # We want to try:
664     #    0. `instead of' distro name(s) we have been pointed to
665     #    1. the access_quirk distro, if any
666     #    2a. the user's specified distro, or failing that  } basedistro
667     #    2b. the distro calculated from the suite          }
668     my @l = access_basedistro();
669
670     my (undef,$quirkdistro) = access_quirk();
671     unshift @l, $quirkdistro;
672     unshift @l, $instead_distro;
673     @l = grep { defined } @l;
674
675     if (access_forpush()) {
676         @l = map { ("$_/push", $_) } @l;
677     }
678     @l;
679 }
680
681 sub access_cfg_cfgs (@) {
682     my (@keys) = @_;
683     my @cfgs;
684     # The nesting of these loops determines the search order.  We put
685     # the key loop on the outside so that we search all the distros
686     # for each key, before going on to the next key.  That means that
687     # if access_cfg is called with a more specific, and then a less
688     # specific, key, an earlier distro can override the less specific
689     # without necessarily overriding any more specific keys.  (If the
690     # distro wants to override the more specific keys it can simply do
691     # so; whereas if we did the loop the other way around, it would be
692     # impossible to for an earlier distro to override a less specific
693     # key but not the more specific ones without restating the unknown
694     # values of the more specific keys.
695     my @realkeys;
696     my @rundef;
697     # We have to deal with RETURN-UNDEF specially, so that we don't
698     # terminate the search prematurely.
699     foreach (@keys) {
700         if (m/RETURN-UNDEF/) { push @rundef, $_; last; }
701         push @realkeys, $_
702     }
703     foreach my $d (access_distros()) {
704         push @cfgs, map { "dgit-distro.$d.$_" } @realkeys;
705     }
706     push @cfgs, map { "dgit.default.$_" } @realkeys;
707     push @cfgs, @rundef;
708     return @cfgs;
709 }
710
711 sub access_cfg (@) {
712     my (@keys) = @_;
713     my (@cfgs) = access_cfg_cfgs(@keys);
714     my $value = cfg(@cfgs);
715     return $value;
716 }
717
718 sub access_cfg_bool ($$) {
719     my ($def, @keys) = @_;
720     parse_cfg_bool($keys[0], $def, access_cfg(@keys, 'RETURN-UNDEF'));
721 }
722
723 sub string_to_ssh ($) {
724     my ($spec) = @_;
725     if ($spec =~ m/\s/) {
726         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
727     } else {
728         return ($spec);
729     }
730 }
731
732 sub access_cfg_ssh () {
733     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
734     if (!defined $gitssh) {
735         return @ssh;
736     } else {
737         return string_to_ssh $gitssh;
738     }
739 }
740
741 sub access_runeinfo ($) {
742     my ($info) = @_;
743     return ": dgit ".access_basedistro()." $info ;";
744 }
745
746 sub access_someuserhost ($) {
747     my ($some) = @_;
748     my $user = access_cfg("$some-user-force", 'RETURN-UNDEF');
749     defined($user) && length($user) or
750         $user = access_cfg("$some-user",'username');
751     my $host = access_cfg("$some-host");
752     return length($user) ? "$user\@$host" : $host;
753 }
754
755 sub access_gituserhost () {
756     return access_someuserhost('git');
757 }
758
759 sub access_giturl (;$) {
760     my ($optional) = @_;
761     my $url = access_cfg('git-url','RETURN-UNDEF');
762     my $suffix;
763     if (!length $url) {
764         my $proto = access_cfg('git-proto', 'RETURN-UNDEF');
765         return undef unless defined $proto;
766         $url =
767             $proto.
768             access_gituserhost().
769             access_cfg('git-path');
770     } else {
771         $suffix = access_cfg('git-url-suffix','RETURN-UNDEF');
772     }
773     $suffix //= '.git';
774     return "$url/$package$suffix";
775 }              
776
777 sub parsecontrolfh ($$;$) {
778     my ($fh, $desc, $allowsigned) = @_;
779     our $dpkgcontrolhash_noissigned;
780     my $c;
781     for (;;) {
782         my %opts = ('name' => $desc);
783         $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
784         $c = Dpkg::Control::Hash->new(%opts);
785         $c->parse($fh,$desc) or die "parsing of $desc failed";
786         last if $allowsigned;
787         last if $dpkgcontrolhash_noissigned;
788         my $issigned= $c->get_option('is_pgp_signed');
789         if (!defined $issigned) {
790             $dpkgcontrolhash_noissigned= 1;
791             seek $fh, 0,0 or die "seek $desc: $!";
792         } elsif ($issigned) {
793             fail "control file $desc is (already) PGP-signed. ".
794                 " Note that dgit push needs to modify the .dsc and then".
795                 " do the signature itself";
796         } else {
797             last;
798         }
799     }
800     return $c;
801 }
802
803 sub parsecontrol {
804     my ($file, $desc) = @_;
805     my $fh = new IO::Handle;
806     open $fh, '<', $file or die "$file: $!";
807     my $c = parsecontrolfh($fh,$desc);
808     $fh->error and die $!;
809     close $fh;
810     return $c;
811 }
812
813 sub getfield ($$) {
814     my ($dctrl,$field) = @_;
815     my $v = $dctrl->{$field};
816     return $v if defined $v;
817     fail "missing field $field in ".$v->get_option('name');
818 }
819
820 sub parsechangelog {
821     my $c = Dpkg::Control::Hash->new();
822     my $p = new IO::Handle;
823     my @cmd = (qw(dpkg-parsechangelog), @_);
824     open $p, '-|', @cmd or die $!;
825     $c->parse($p);
826     $?=0; $!=0; close $p or failedcmd @cmd;
827     return $c;
828 }
829
830 sub must_getcwd () {
831     my $d = getcwd();
832     defined $d or fail "getcwd failed: $!";
833     return $d;
834 }
835
836 our %rmad;
837
838 sub archive_query ($) {
839     my ($method) = @_;
840     my $query = access_cfg('archive-query','RETURN-UNDEF');
841     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
842     my $proto = $1;
843     my $data = $'; #';
844     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
845 }
846
847 sub pool_dsc_subpath ($$) {
848     my ($vsn,$component) = @_; # $package is implict arg
849     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
850     return "/pool/$component/$prefix/$package/".dscfn($vsn);
851 }
852
853 #---------- `ftpmasterapi' archive query method (nascent) ----------
854
855 sub archive_api_query_cmd ($) {
856     my ($subpath) = @_;
857     my @cmd = qw(curl -sS);
858     my $url = access_cfg('archive-query-url');
859     if ($url =~ m#^https://([-.0-9a-z]+)/#) {
860         my $host = $1;
861         my $keys = access_cfg('archive-query-tls-key','RETURN-UNDEF') //'';
862         foreach my $key (split /\:/, $keys) {
863             $key =~ s/\%HOST\%/$host/g;
864             if (!stat $key) {
865                 fail "for $url: stat $key: $!" unless $!==ENOENT;
866                 next;
867             }
868             fail "config requested specific TLS key but do not know".
869                 " how to get curl to use exactly that EE key ($key)";
870 #           push @cmd, "--cacert", $key, "--capath", "/dev/enoent";
871 #           # Sadly the above line does not work because of changes
872 #           # to gnutls.   The real fix for #790093 may involve
873 #           # new curl options.
874             last;
875         }
876         # Fixing #790093 properly will involve providing a value
877         # for this on clients.
878         my $kargs = access_cfg('archive-query-tls-curl-ca-args','RETURN-UNDEF');
879         push @cmd, split / /, $kargs if defined $kargs;
880     }
881     push @cmd, $url.$subpath;
882     return @cmd;
883 }
884
885 sub api_query ($$) {
886     use JSON;
887     my ($data, $subpath) = @_;
888     badcfg "ftpmasterapi archive query method takes no data part"
889         if length $data;
890     my @cmd = archive_api_query_cmd($subpath);
891     my $json = cmdoutput @cmd;
892     return decode_json($json);
893 }
894
895 sub canonicalise_suite_ftpmasterapi () {
896     my ($proto,$data) = @_;
897     my $suites = api_query($data, 'suites');
898     my @matched;
899     foreach my $entry (@$suites) {
900         next unless grep { 
901             my $v = $entry->{$_};
902             defined $v && $v eq $isuite;
903         } qw(codename name);
904         push @matched, $entry;
905     }
906     fail "unknown suite $isuite" unless @matched;
907     my $cn;
908     eval {
909         @matched==1 or die "multiple matches for suite $isuite\n";
910         $cn = "$matched[0]{codename}";
911         defined $cn or die "suite $isuite info has no codename\n";
912         $cn =~ m/^$suite_re$/ or die "suite $isuite maps to bad codename\n";
913     };
914     die "bad ftpmaster api response: $@\n".Dumper(\@matched)
915         if length $@;
916     return $cn;
917 }
918
919 sub archive_query_ftpmasterapi () {
920     my ($proto,$data) = @_;
921     my $info = api_query($data, "dsc_in_suite/$isuite/$package");
922     my @rows;
923     my $digester = Digest::SHA->new(256);
924     foreach my $entry (@$info) {
925         eval {
926             my $vsn = "$entry->{version}";
927             my ($ok,$msg) = version_check $vsn;
928             die "bad version: $msg\n" unless $ok;
929             my $component = "$entry->{component}";
930             $component =~ m/^$component_re$/ or die "bad component";
931             my $filename = "$entry->{filename}";
932             $filename && $filename !~ m#[^-+:._~0-9a-zA-Z/]|^[/.]|/[/.]#
933                 or die "bad filename";
934             my $sha256sum = "$entry->{sha256sum}";
935             $sha256sum =~ m/^[0-9a-f]+$/ or die "bad sha256sum";
936             push @rows, [ $vsn, "/pool/$component/$filename",
937                           $digester, $sha256sum ];
938         };
939         die "bad ftpmaster api response: $@\n".Dumper($entry)
940             if length $@;
941     }
942     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
943     return @rows;
944 }
945
946 #---------- `madison' archive query method ----------
947
948 sub archive_query_madison {
949     return map { [ @$_[0..1] ] } madison_get_parse(@_);
950 }
951
952 sub madison_get_parse {
953     my ($proto,$data) = @_;
954     die unless $proto eq 'madison';
955     if (!length $data) {
956         $data= access_cfg('madison-distro','RETURN-UNDEF');
957         $data //= access_basedistro();
958     }
959     $rmad{$proto,$data,$package} ||= cmdoutput
960         qw(rmadison -asource),"-s$isuite","-u$data",$package;
961     my $rmad = $rmad{$proto,$data,$package};
962
963     my @out;
964     foreach my $l (split /\n/, $rmad) {
965         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
966                   \s*( [^ \t|]+ )\s* \|
967                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
968                   \s*( [^ \t|]+ )\s* }x or die "$rmad ?";
969         $1 eq $package or die "$rmad $package ?";
970         my $vsn = $2;
971         my $newsuite = $3;
972         my $component;
973         if (defined $4) {
974             $component = $4;
975         } else {
976             $component = access_cfg('archive-query-default-component');
977         }
978         $5 eq 'source' or die "$rmad ?";
979         push @out, [$vsn,pool_dsc_subpath($vsn,$component),$newsuite];
980     }
981     return sort { -version_compare($a->[0],$b->[0]); } @out;
982 }
983
984 sub canonicalise_suite_madison {
985     # madison canonicalises for us
986     my @r = madison_get_parse(@_);
987     @r or fail
988         "unable to canonicalise suite using package $package".
989         " which does not appear to exist in suite $isuite;".
990         " --existing-package may help";
991     return $r[0][2];
992 }
993
994 #---------- `sshpsql' archive query method ----------
995
996 sub sshpsql ($$$) {
997     my ($data,$runeinfo,$sql) = @_;
998     if (!length $data) {
999         $data= access_someuserhost('sshpsql').':'.
1000             access_cfg('sshpsql-dbname');
1001     }
1002     $data =~ m/:/ or badcfg "invalid sshpsql method string \`$data'";
1003     my ($userhost,$dbname) = ($`,$'); #';
1004     my @rows;
1005     my @cmd = (access_cfg_ssh, $userhost,
1006                access_runeinfo("ssh-psql $runeinfo").
1007                " export LC_MESSAGES=C; export LC_CTYPE=C;".
1008                " ".shellquote qw(psql -A), $dbname, qw(-c), $sql);
1009     debugcmd "|",@cmd;
1010     open P, "-|", @cmd or die $!;
1011     while (<P>) {
1012         chomp or die;
1013         printdebug(">|$_|\n");
1014         push @rows, $_;
1015     }
1016     $!=0; $?=0; close P or failedcmd @cmd;
1017     @rows or die;
1018     my $nrows = pop @rows;
1019     $nrows =~ s/^\((\d+) rows?\)$/$1/ or die "$nrows ?";
1020     @rows == $nrows+1 or die "$nrows ".(scalar @rows)." ?";
1021     @rows = map { [ split /\|/, $_ ] } @rows;
1022     my $ncols = scalar @{ shift @rows };
1023     die if grep { scalar @$_ != $ncols } @rows;
1024     return @rows;
1025 }
1026
1027 sub sql_injection_check {
1028     foreach (@_) { die "$_ $& ?" if m{[^-+=:_.,/0-9a-zA-Z]}; }
1029 }
1030
1031 sub archive_query_sshpsql ($$) {
1032     my ($proto,$data) = @_;
1033     sql_injection_check $isuite, $package;
1034     my @rows = sshpsql($data, "archive-query $isuite $package", <<END);
1035         SELECT source.version, component.name, files.filename, files.sha256sum
1036           FROM source
1037           JOIN src_associations ON source.id = src_associations.source
1038           JOIN suite ON suite.id = src_associations.suite
1039           JOIN dsc_files ON dsc_files.source = source.id
1040           JOIN files_archive_map ON files_archive_map.file_id = dsc_files.file
1041           JOIN component ON component.id = files_archive_map.component_id
1042           JOIN files ON files.id = dsc_files.file
1043          WHERE ( suite.suite_name='$isuite' OR suite.codename='$isuite' )
1044            AND source.source='$package'
1045            AND files.filename LIKE '%.dsc';
1046 END
1047     @rows = sort { -version_compare($a->[0],$b->[0]) } @rows;
1048     my $digester = Digest::SHA->new(256);
1049     @rows = map {
1050         my ($vsn,$component,$filename,$sha256sum) = @$_;
1051         [ $vsn, "/pool/$component/$filename",$digester,$sha256sum ];
1052     } @rows;
1053     return @rows;
1054 }
1055
1056 sub canonicalise_suite_sshpsql ($$) {
1057     my ($proto,$data) = @_;
1058     sql_injection_check $isuite;
1059     my @rows = sshpsql($data, "canonicalise-suite $isuite", <<END);
1060         SELECT suite.codename
1061           FROM suite where suite_name='$isuite' or codename='$isuite';
1062 END
1063     @rows = map { $_->[0] } @rows;
1064     fail "unknown suite $isuite" unless @rows;
1065     die "ambiguous $isuite: @rows ?" if @rows>1;
1066     return $rows[0];
1067 }
1068
1069 #---------- `dummycat' archive query method ----------
1070
1071 sub canonicalise_suite_dummycat ($$) {
1072     my ($proto,$data) = @_;
1073     my $dpath = "$data/suite.$isuite";
1074     if (!open C, "<", $dpath) {
1075         $!==ENOENT or die "$dpath: $!";
1076         printdebug "dummycat canonicalise_suite $isuite $dpath ENOENT\n";
1077         return $isuite;
1078     }
1079     $!=0; $_ = <C>;
1080     chomp or die "$dpath: $!";
1081     close C;
1082     printdebug "dummycat canonicalise_suite $isuite $dpath = $_\n";
1083     return $_;
1084 }
1085
1086 sub archive_query_dummycat ($$) {
1087     my ($proto,$data) = @_;
1088     canonicalise_suite();
1089     my $dpath = "$data/package.$csuite.$package";
1090     if (!open C, "<", $dpath) {
1091         $!==ENOENT or die "$dpath: $!";
1092         printdebug "dummycat query $csuite $package $dpath ENOENT\n";
1093         return ();
1094     }
1095     my @rows;
1096     while (<C>) {
1097         next if m/^\#/;
1098         next unless m/\S/;
1099         die unless chomp;
1100         printdebug "dummycat query $csuite $package $dpath | $_\n";
1101         my @row = split /\s+/, $_;
1102         @row==2 or die "$dpath: $_ ?";
1103         push @rows, \@row;
1104     }
1105     C->error and die "$dpath: $!";
1106     close C;
1107     return sort { -version_compare($a->[0],$b->[0]); } @rows;
1108 }
1109
1110 #---------- archive query entrypoints and rest of program ----------
1111
1112 sub canonicalise_suite () {
1113     return if defined $csuite;
1114     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
1115     $csuite = archive_query('canonicalise_suite');
1116     if ($isuite ne $csuite) {
1117         progress "canonical suite name for $isuite is $csuite";
1118     }
1119 }
1120
1121 sub get_archive_dsc () {
1122     canonicalise_suite();
1123     my @vsns = archive_query('archive_query');
1124     foreach my $vinfo (@vsns) {
1125         my ($vsn,$subpath,$digester,$digest) = @$vinfo;
1126         $dscurl = access_cfg('mirror').$subpath;
1127         $dscdata = url_get($dscurl);
1128         if (!$dscdata) {
1129             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1130             next;
1131         }
1132         if ($digester) {
1133             $digester->reset();
1134             $digester->add($dscdata);
1135             my $got = $digester->hexdigest();
1136             $got eq $digest or
1137                 fail "$dscurl has hash $got but".
1138                     " archive told us to expect $digest";
1139         }
1140         my $dscfh = new IO::File \$dscdata, '<' or die $!;
1141         printdebug Dumper($dscdata) if $debuglevel>1;
1142         $dsc = parsecontrolfh($dscfh,$dscurl,1);
1143         printdebug Dumper($dsc) if $debuglevel>1;
1144         my $fmt = getfield $dsc, 'Format';
1145         fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
1146         $dsc_checked = !!$digester;
1147         return;
1148     }
1149     $dsc = undef;
1150 }
1151
1152 sub check_for_git ();
1153 sub check_for_git () {
1154     # returns 0 or 1
1155     my $how = access_cfg('git-check');
1156     if ($how eq 'ssh-cmd') {
1157         my @cmd =
1158             (access_cfg_ssh, access_gituserhost(),
1159              access_runeinfo("git-check $package").
1160              " set -e; cd ".access_cfg('git-path').";".
1161              " if test -d $package.git; then echo 1; else echo 0; fi");
1162         my $r= cmdoutput @cmd;
1163         if ($r =~ m/^divert (\w+)$/) {
1164             my $divert=$1;
1165             my ($usedistro,) = access_distros();
1166             # NB that if we are pushing, $usedistro will be $distro/push
1167             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1168             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1169             progress "diverting to $divert (using config for $instead_distro)";
1170             return check_for_git();
1171         }
1172         failedcmd @cmd unless $r =~ m/^[01]$/;
1173         return $r+0;
1174     } elsif ($how eq 'url') {
1175         my $prefix = access_cfg('git-check-url','git-url');
1176         my $suffix = access_cfg('git-check-suffix','git-suffix',
1177                                 'RETURN-UNDEF') // '.git';
1178         my $url = "$prefix/$package$suffix";
1179         my @cmd = (qw(curl -sS -I), $url);
1180         my $result = cmdoutput @cmd;
1181         $result =~ s/^\S+ 200 .*\n\r?\n//;
1182         # curl -sS -I with https_proxy prints
1183         # HTTP/1.0 200 Connection established
1184         $result =~ m/^\S+ (404|200) /s or
1185             fail "unexpected results from git check query - ".
1186                 Dumper($prefix, $result);
1187         my $code = $1;
1188         if ($code eq '404') {
1189             return 0;
1190         } elsif ($code eq '200') {
1191             return 1;
1192         } else {
1193             die;
1194         }
1195     } elsif ($how eq 'true') {
1196         return 1;
1197     } elsif ($how eq 'false') {
1198         return 0;
1199     } else {
1200         badcfg "unknown git-check \`$how'";
1201     }
1202 }
1203
1204 sub create_remote_git_repo () {
1205     my $how = access_cfg('git-create');
1206     if ($how eq 'ssh-cmd') {
1207         runcmd_ordryrun
1208             (access_cfg_ssh, access_gituserhost(),
1209              access_runeinfo("git-create $package").
1210              "set -e; cd ".access_cfg('git-path').";".
1211              " cp -a _template $package.git");
1212     } elsif ($how eq 'true') {
1213         # nothing to do
1214     } else {
1215         badcfg "unknown git-create \`$how'";
1216     }
1217 }
1218
1219 our ($dsc_hash,$lastpush_hash);
1220
1221 our $ud = '.git/dgit/unpack';
1222
1223 sub prep_ud (;$) {
1224     my ($d) = @_;
1225     $d //= $ud;
1226     rmtree($d);
1227     mkpath '.git/dgit';
1228     mkdir $d or die $!;
1229 }
1230
1231 sub mktree_in_ud_here () {
1232     runcmd qw(git init -q);
1233     rmtree('.git/objects');
1234     symlink '../../../../objects','.git/objects' or die $!;
1235 }
1236
1237 sub git_write_tree () {
1238     my $tree = cmdoutput @git, qw(write-tree);
1239     $tree =~ m/^\w+$/ or die "$tree ?";
1240     return $tree;
1241 }
1242
1243 sub remove_stray_gits () {
1244     my @gitscmd = qw(find -name .git -prune -print0);
1245     debugcmd "|",@gitscmd;
1246     open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1247     {
1248         local $/="\0";
1249         while (<GITS>) {
1250             chomp or die;
1251             print STDERR "$us: warning: removing from source package: ",
1252                 (messagequote $_), "\n";
1253             rmtree $_;
1254         }
1255     }
1256     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1257 }
1258
1259 sub mktree_in_ud_from_only_subdir () {
1260     # changes into the subdir
1261     my (@dirs) = <*/.>;
1262     die unless @dirs==1;
1263     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1264     my $dir = $1;
1265     changedir $dir;
1266
1267     remove_stray_gits();
1268     mktree_in_ud_here();
1269     my ($format, $fopts) = get_source_format();
1270     if (madformat($format)) {
1271         rmtree '.pc';
1272     }
1273     runcmd @git, qw(add -Af);
1274     my $tree=git_write_tree();
1275     return ($tree,$dir);
1276 }
1277
1278 sub dsc_files_info () {
1279     foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1280                        ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1281                        ['Files',           'Digest::MD5', 'new()']) {
1282         my ($fname, $module, $method) = @$csumi;
1283         my $field = $dsc->{$fname};
1284         next unless defined $field;
1285         eval "use $module; 1;" or die $@;
1286         my @out;
1287         foreach (split /\n/, $field) {
1288             next unless m/\S/;
1289             m/^(\w+) (\d+) (\S+)$/ or
1290                 fail "could not parse .dsc $fname line \`$_'";
1291             my $digester = eval "$module"."->$method;" or die $@;
1292             push @out, {
1293                 Hash => $1,
1294                 Bytes => $2,
1295                 Filename => $3,
1296                 Digester => $digester,
1297             };
1298         }
1299         return @out;
1300     }
1301     fail "missing any supported Checksums-* or Files field in ".
1302         $dsc->get_option('name');
1303 }
1304
1305 sub dsc_files () {
1306     map { $_->{Filename} } dsc_files_info();
1307 }
1308
1309 sub is_orig_file ($;$) {
1310     local ($_) = $_[0];
1311     my $base = $_[1];
1312     m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1313     defined $base or return 1;
1314     return $` eq $base;
1315 }
1316
1317 sub make_commit ($) {
1318     my ($file) = @_;
1319     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1320 }
1321
1322 sub clogp_authline ($) {
1323     my ($clogp) = @_;
1324     my $author = getfield $clogp, 'Maintainer';
1325     $author =~ s#,.*##ms;
1326     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1327     my $authline = "$author $date";
1328     $authline =~ m/$git_authline_re/o or
1329         fail "unexpected commit author line format \`$authline'".
1330         " (was generated from changelog Maintainer field)";
1331     return ($1,$2,$3) if wantarray;
1332     return $authline;
1333 }
1334
1335 sub vendor_patches_distro ($$) {
1336     my ($checkdistro, $what) = @_;
1337     return unless defined $checkdistro;
1338
1339     my $series = "debian/patches/\L$checkdistro\E.series";
1340     printdebug "checking for vendor-specific $series ($what)\n";
1341
1342     if (!open SERIES, "<", $series) {
1343         die "$series $!" unless $!==ENOENT;
1344         return;
1345     }
1346     while (<SERIES>) {
1347         next unless m/\S/;
1348         next if m/^\s+\#/;
1349
1350         print STDERR <<END;
1351
1352 Unfortunately, this source package uses a feature of dpkg-source where
1353 the same source package unpacks to different source code on different
1354 distros.  dgit cannot safely operate on such packages on affected
1355 distros, because the meaning of source packages is not stable.
1356
1357 Please ask the distro/maintainer to remove the distro-specific series
1358 files and use a different technique (if necessary, uploading actually
1359 different packages, if different distros are supposed to have
1360 different code).
1361
1362 END
1363         fail "Found active distro-specific series file for".
1364             " $checkdistro ($what): $series, cannot continue";
1365     }
1366     die "$series $!" if SERIES->error;
1367     close SERIES;
1368 }
1369
1370 sub check_for_vendor_patches () {
1371     # This dpkg-source feature doesn't seem to be documented anywhere!
1372     # But it can be found in the changelog (reformatted):
1373
1374     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1375     #   Author: Raphael Hertzog <hertzog@debian.org>
1376     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1377
1378     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1379     #   series files
1380     #   
1381     #   If you have debian/patches/ubuntu.series and you were
1382     #   unpacking the source package on ubuntu, quilt was still
1383     #   directed to debian/patches/series instead of
1384     #   debian/patches/ubuntu.series.
1385     #   
1386     #   debian/changelog                        |    3 +++
1387     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1388     #   2 files changed, 6 insertions(+), 1 deletion(-)
1389
1390     use Dpkg::Vendor;
1391     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1392     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1393                          "Dpkg::Vendor \`current vendor'");
1394     vendor_patches_distro(access_basedistro(),
1395                           "distro being accessed");
1396 }
1397
1398 sub generate_commit_from_dsc () {
1399     prep_ud();
1400     changedir $ud;
1401
1402     foreach my $fi (dsc_files_info()) {
1403         my $f = $fi->{Filename};
1404         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1405
1406         link_ltarget "../../../$f", $f
1407             or $!==&ENOENT
1408             or die "$f $!";
1409
1410         complete_file_from_dsc('.', $fi)
1411             or next;
1412
1413         if (is_orig_file($f)) {
1414             link $f, "../../../../$f"
1415                 or $!==&EEXIST
1416                 or die "$f $!";
1417         }
1418     }
1419
1420     my $dscfn = "$package.dsc";
1421
1422     open D, ">", $dscfn or die "$dscfn: $!";
1423     print D $dscdata or die "$dscfn: $!";
1424     close D or die "$dscfn: $!";
1425     my @cmd = qw(dpkg-source);
1426     push @cmd, '--no-check' if $dsc_checked;
1427     push @cmd, qw(-x --), $dscfn;
1428     runcmd @cmd;
1429
1430     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1431     check_for_vendor_patches() if madformat($dsc->{format});
1432     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1433     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1434     my $authline = clogp_authline $clogp;
1435     my $changes = getfield $clogp, 'Changes';
1436     open C, ">../commit.tmp" or die $!;
1437     print C <<END or die $!;
1438 tree $tree
1439 author $authline
1440 committer $authline
1441
1442 $changes
1443
1444 # imported from the archive
1445 END
1446     close C or die $!;
1447     my $outputhash = make_commit qw(../commit.tmp);
1448     my $cversion = getfield $clogp, 'Version';
1449     progress "synthesised git commit from .dsc $cversion";
1450     if ($lastpush_hash) {
1451         runcmd @git, qw(reset --hard), $lastpush_hash;
1452         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1453         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1454         my $oversion = getfield $oldclogp, 'Version';
1455         my $vcmp =
1456             version_compare($oversion, $cversion);
1457         if ($vcmp < 0) {
1458             # git upload/ is earlier vsn than archive, use archive
1459             open C, ">../commit2.tmp" or die $!;
1460             print C <<END or die $!;
1461 tree $tree
1462 parent $lastpush_hash
1463 parent $outputhash
1464 author $authline
1465 committer $authline
1466
1467 Record $package ($cversion) in archive suite $csuite
1468 END
1469             $outputhash = make_commit qw(../commit2.tmp);
1470         } elsif ($vcmp > 0) {
1471             print STDERR <<END or die $!;
1472
1473 Version actually in archive:    $cversion (older)
1474 Last allegedly pushed/uploaded: $oversion (newer or same)
1475 $later_warning_msg
1476 END
1477             $outputhash = $lastpush_hash;
1478         } else {
1479             $outputhash = $lastpush_hash;
1480         }
1481     }
1482     changedir '../../../..';
1483     runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1484             'DGIT_ARCHIVE', $outputhash;
1485     cmdoutput @git, qw(log -n2), $outputhash;
1486     # ... gives git a chance to complain if our commit is malformed
1487     rmtree($ud);
1488     return $outputhash;
1489 }
1490
1491 sub complete_file_from_dsc ($$) {
1492     our ($dstdir, $fi) = @_;
1493     # Ensures that we have, in $dir, the file $fi, with the correct
1494     # contents.  (Downloading it from alongside $dscurl if necessary.)
1495
1496     my $f = $fi->{Filename};
1497     my $tf = "$dstdir/$f";
1498     my $downloaded = 0;
1499
1500     if (stat_exists $tf) {
1501         progress "using existing $f";
1502     } else {
1503         my $furl = $dscurl;
1504         $furl =~ s{/[^/]+$}{};
1505         $furl .= "/$f";
1506         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1507         die "$f ?" if $f =~ m#/#;
1508         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1509         return 0 if !act_local();
1510         $downloaded = 1;
1511     }
1512
1513     open F, "<", "$tf" or die "$tf: $!";
1514     $fi->{Digester}->reset();
1515     $fi->{Digester}->addfile(*F);
1516     F->error and die $!;
1517     my $got = $fi->{Digester}->hexdigest();
1518     $got eq $fi->{Hash} or
1519         fail "file $f has hash $got but .dsc".
1520             " demands hash $fi->{Hash} ".
1521             ($downloaded ? "(got wrong file from archive!)"
1522              : "(perhaps you should delete this file?)");
1523
1524     return 1;
1525 }
1526
1527 sub ensure_we_have_orig () {
1528     foreach my $fi (dsc_files_info()) {
1529         my $f = $fi->{Filename};
1530         next unless is_orig_file($f);
1531         complete_file_from_dsc('..', $fi)
1532             or next;
1533     }
1534 }
1535
1536 sub git_fetch_us () {
1537     my @specs = (fetchspec());
1538     push @specs,
1539         map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1540         qw(tags heads);
1541     runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1542
1543     my %here;
1544     my $tagpat = debiantag('*',access_basedistro);
1545
1546     git_for_each_ref("refs/tags/".$tagpat, sub {
1547         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1548         printdebug "currently $fullrefname=$objid\n";
1549         $here{$fullrefname} = $objid;
1550     });
1551     git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1552         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1553         my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1554         printdebug "offered $lref=$objid\n";
1555         if (!defined $here{$lref}) {
1556             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1557             runcmd_ordryrun_local @upd;
1558         } elsif ($here{$lref} eq $objid) {
1559         } else {
1560             print STDERR \
1561                 "Not updateting $lref from $here{$lref} to $objid.\n";
1562         }
1563     });
1564 }
1565
1566 sub fetch_from_archive () {
1567     # ensures that lrref() is what is actually in the archive,
1568     #  one way or another
1569     get_archive_dsc();
1570
1571     if ($dsc) {
1572         foreach my $field (@ourdscfield) {
1573             $dsc_hash = $dsc->{$field};
1574             last if defined $dsc_hash;
1575         }
1576         if (defined $dsc_hash) {
1577             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1578             $dsc_hash = $&;
1579             progress "last upload to archive specified git hash";
1580         } else {
1581             progress "last upload to archive has NO git hash";
1582         }
1583     } else {
1584         progress "no version available from the archive";
1585     }
1586
1587     $lastpush_hash = git_get_ref(lrref());
1588     printdebug "previous reference hash=$lastpush_hash\n";
1589     my $hash;
1590     if (defined $dsc_hash) {
1591         fail "missing remote git history even though dsc has hash -".
1592             " could not find ref ".lrref().
1593             " (should have been fetched from ".access_giturl()."#".rrref().")"
1594             unless $lastpush_hash;
1595         $hash = $dsc_hash;
1596         ensure_we_have_orig();
1597         if ($dsc_hash eq $lastpush_hash) {
1598         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1599             print STDERR <<END or die $!;
1600
1601 Git commit in archive is behind the last version allegedly pushed/uploaded.
1602 Commit referred to by archive:  $dsc_hash
1603 Last allegedly pushed/uploaded: $lastpush_hash
1604 $later_warning_msg
1605 END
1606             $hash = $lastpush_hash;
1607         } else {
1608             fail "git head (".lrref()."=$lastpush_hash) is not a ".
1609                 "descendant of archive's .dsc hash ($dsc_hash)";
1610         }
1611     } elsif ($dsc) {
1612         $hash = generate_commit_from_dsc();
1613     } elsif ($lastpush_hash) {
1614         # only in git, not in the archive yet
1615         $hash = $lastpush_hash;
1616         print STDERR <<END or die $!;
1617
1618 Package not found in the archive, but has allegedly been pushed using dgit.
1619 $later_warning_msg
1620 END
1621     } else {
1622         printdebug "nothing found!\n";
1623         if (defined $skew_warning_vsn) {
1624             print STDERR <<END or die $!;
1625
1626 Warning: relevant archive skew detected.
1627 Archive allegedly contains $skew_warning_vsn
1628 But we were not able to obtain any version from the archive or git.
1629
1630 END
1631         }
1632         return 0;
1633     }
1634     printdebug "current hash=$hash\n";
1635     if ($lastpush_hash) {
1636         fail "not fast forward on last upload branch!".
1637             " (archive's version left in DGIT_ARCHIVE)"
1638             unless is_fast_fwd($lastpush_hash, $hash);
1639     }
1640     if (defined $skew_warning_vsn) {
1641         mkpath '.git/dgit';
1642         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1643         my $clogf = ".git/dgit/changelog.tmp";
1644         runcmd shell_cmd "exec >$clogf",
1645             @git, qw(cat-file blob), "$hash:debian/changelog";
1646         my $gotclogp = parsechangelog("-l$clogf");
1647         my $got_vsn = getfield $gotclogp, 'Version';
1648         printdebug "SKEW CHECK GOT $got_vsn\n";
1649         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1650             print STDERR <<END or die $!;
1651
1652 Warning: archive skew detected.  Using the available version:
1653 Archive allegedly contains    $skew_warning_vsn
1654 We were able to obtain only   $got_vsn
1655
1656 END
1657         }
1658     }
1659     if ($lastpush_hash ne $hash) {
1660         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1661         if (act_local()) {
1662             cmdoutput @upd_cmd;
1663         } else {
1664             dryrun_report @upd_cmd;
1665         }
1666     }
1667     return 1;
1668 }
1669
1670 sub set_local_git_config ($$) {
1671     my ($k, $v) = @_;
1672     runcmd @git, qw(config), $k, $v;
1673 }
1674
1675 sub setup_mergechangelogs (;$) {
1676     my ($always) = @_;
1677     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1678
1679     my $driver = 'dpkg-mergechangelogs';
1680     my $cb = "merge.$driver";
1681     my $attrs = '.git/info/attributes';
1682     ensuredir '.git/info';
1683
1684     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1685     if (!open ATTRS, "<", $attrs) {
1686         $!==ENOENT or die "$attrs: $!";
1687     } else {
1688         while (<ATTRS>) {
1689             chomp;
1690             next if m{^debian/changelog\s};
1691             print NATTRS $_, "\n" or die $!;
1692         }
1693         ATTRS->error and die $!;
1694         close ATTRS;
1695     }
1696     print NATTRS "debian/changelog merge=$driver\n" or die $!;
1697     close NATTRS;
1698
1699     set_local_git_config "$cb.name", 'debian/changelog merge driver';
1700     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1701
1702     rename "$attrs.new", "$attrs" or die "$attrs: $!";
1703 }
1704
1705 sub setup_useremail (;$) {
1706     my ($always) = @_;
1707     return unless $always || access_cfg_bool(1, 'setup-useremail');
1708
1709     my $setup = sub {
1710         my ($k, $envvar) = @_;
1711         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1712         return unless defined $v;
1713         set_local_git_config "user.$k", $v;
1714     };
1715
1716     $setup->('email', 'DEBEMAIL');
1717     $setup->('name', 'DEBFULLNAME');
1718 }
1719
1720 sub setup_new_tree () {
1721     setup_mergechangelogs();
1722     setup_useremail();
1723 }
1724
1725 sub clone ($) {
1726     my ($dstdir) = @_;
1727     canonicalise_suite();
1728     badusage "dry run makes no sense with clone" unless act_local();
1729     my $hasgit = check_for_git();
1730     mkdir $dstdir or fail "create \`$dstdir': $!";
1731     changedir $dstdir;
1732     runcmd @git, qw(init -q);
1733     my $giturl = access_giturl(1);
1734     if (defined $giturl) {
1735         set_local_git_config "remote.$remotename.fetch", fetchspec();
1736         open H, "> .git/HEAD" or die $!;
1737         print H "ref: ".lref()."\n" or die $!;
1738         close H or die $!;
1739         runcmd @git, qw(remote add), 'origin', $giturl;
1740     }
1741     if ($hasgit) {
1742         progress "fetching existing git history";
1743         git_fetch_us();
1744         runcmd_ordryrun_local @git, qw(fetch origin);
1745     } else {
1746         progress "starting new git history";
1747     }
1748     fetch_from_archive() or no_such_package;
1749     my $vcsgiturl = $dsc->{'Vcs-Git'};
1750     if (length $vcsgiturl) {
1751         $vcsgiturl =~ s/\s+-b\s+\S+//g;
1752         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1753     }
1754     setup_new_tree();
1755     runcmd @git, qw(reset --hard), lrref();
1756     printdone "ready for work in $dstdir";
1757 }
1758
1759 sub fetch () {
1760     if (check_for_git()) {
1761         git_fetch_us();
1762     }
1763     fetch_from_archive() or no_such_package();
1764     printdone "fetched into ".lrref();
1765 }
1766
1767 sub pull () {
1768     fetch();
1769     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1770         lrref();
1771     printdone "fetched to ".lrref()." and merged into HEAD";
1772 }
1773
1774 sub check_not_dirty () {
1775     foreach my $f (qw(local-options local-patch-header)) {
1776         if (stat_exists "debian/source/$f") {
1777             fail "git tree contains debian/source/$f";
1778         }
1779     }
1780
1781     return if $ignoredirty;
1782
1783     my @cmd = (@git, qw(diff --quiet HEAD));
1784     debugcmd "+",@cmd;
1785     $!=0; $?=0; system @cmd;
1786     return if !$! && !$?;
1787     if (!$! && $?==256) {
1788         fail "working tree is dirty (does not match HEAD)";
1789     } else {
1790         failedcmd @cmd;
1791     }
1792 }
1793
1794 sub commit_admin ($) {
1795     my ($m) = @_;
1796     progress "$m";
1797     runcmd_ordryrun_local @git, qw(commit -m), $m;
1798 }
1799
1800 sub commit_quilty_patch () {
1801     my $output = cmdoutput @git, qw(status --porcelain);
1802     my %adds;
1803     foreach my $l (split /\n/, $output) {
1804         next unless $l =~ m/\S/;
1805         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1806             $adds{$1}++;
1807         }
1808     }
1809     delete $adds{'.pc'}; # if there wasn't one before, don't add it
1810     if (!%adds) {
1811         progress "nothing quilty to commit, ok.";
1812         return;
1813     }
1814     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1815     runcmd_ordryrun_local @git, qw(add -f), @adds;
1816     commit_admin "Commit Debian 3.0 (quilt) metadata";
1817 }
1818
1819 sub get_source_format () {
1820     my %options;
1821     if (open F, "debian/source/options") {
1822         while (<F>) {
1823             next if m/^\s*\#/;
1824             next unless m/\S/;
1825             s/\s+$//; # ignore missing final newline
1826             if (m/\s*\#\s*/) {
1827                 my ($k, $v) = ($`, $'); #');
1828                 $v =~ s/^"(.*)"$/$1/;
1829                 $options{$k} = $v;
1830             } else {
1831                 $options{$_} = 1;
1832             }
1833         }
1834         F->error and die $!;
1835         close F;
1836     } else {
1837         die $! unless $!==&ENOENT;
1838     }
1839
1840     if (!open F, "debian/source/format") {
1841         die $! unless $!==&ENOENT;
1842         return '';
1843     }
1844     $_ = <F>;
1845     F->error and die $!;
1846     chomp;
1847     return ($_, \%options);
1848 }
1849
1850 sub madformat ($) {
1851     my ($format) = @_;
1852     return 0 unless $format eq '3.0 (quilt)';
1853     if ($quilt_mode eq 'nocheck') {
1854         progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1855         return 0;
1856     }
1857     progress "Format \`$format', checking/updating patch stack";
1858     return 1;
1859 }
1860
1861 sub push_parse_changelog ($) {
1862     my ($clogpfn) = @_;
1863
1864     my $clogp = Dpkg::Control::Hash->new();
1865     $clogp->load($clogpfn) or die;
1866
1867     $package = getfield $clogp, 'Source';
1868     my $cversion = getfield $clogp, 'Version';
1869     my $tag = debiantag($cversion, access_basedistro);
1870     runcmd @git, qw(check-ref-format), $tag;
1871
1872     my $dscfn = dscfn($cversion);
1873
1874     return ($clogp, $cversion, $tag, $dscfn);
1875 }
1876
1877 sub push_parse_dsc ($$$) {
1878     my ($dscfn,$dscfnwhat, $cversion) = @_;
1879     $dsc = parsecontrol($dscfn,$dscfnwhat);
1880     my $dversion = getfield $dsc, 'Version';
1881     my $dscpackage = getfield $dsc, 'Source';
1882     ($dscpackage eq $package && $dversion eq $cversion) or
1883         fail "$dscfn is for $dscpackage $dversion".
1884             " but debian/changelog is for $package $cversion";
1885 }
1886
1887 sub push_mktag ($$$$$$$) {
1888     my ($head,$clogp,$tag,
1889         $dscfn,
1890         $changesfile,$changesfilewhat,
1891         $tfn) = @_;
1892
1893     $dsc->{$ourdscfield[0]} = $head;
1894     $dsc->save("$dscfn.tmp") or die $!;
1895
1896     my $changes = parsecontrol($changesfile,$changesfilewhat);
1897     foreach my $field (qw(Source Distribution Version)) {
1898         $changes->{$field} eq $clogp->{$field} or
1899             fail "changes field $field \`$changes->{$field}'".
1900                 " does not match changelog \`$clogp->{$field}'";
1901     }
1902
1903     my $cversion = getfield $clogp, 'Version';
1904     my $clogsuite = getfield $clogp, 'Distribution';
1905
1906     # We make the git tag by hand because (a) that makes it easier
1907     # to control the "tagger" (b) we can do remote signing
1908     my $authline = clogp_authline $clogp;
1909     my $delibs = join(" ", "",@deliberatelies);
1910     my $declaredistro = access_basedistro();
1911     open TO, '>', $tfn->('.tmp') or die $!;
1912     print TO <<END or die $!;
1913 object $head
1914 type commit
1915 tag $tag
1916 tagger $authline
1917
1918 $package release $cversion for $clogsuite ($csuite) [dgit]
1919 [dgit distro=$declaredistro$delibs]
1920 END
1921     foreach my $ref (sort keys %previously) {
1922                     print TO <<END or die $!;
1923 [dgit previously:$ref=$previously{$ref}]
1924 END
1925     }
1926
1927     close TO or die $!;
1928
1929     my $tagobjfn = $tfn->('.tmp');
1930     if ($sign) {
1931         if (!defined $keyid) {
1932             $keyid = access_cfg('keyid','RETURN-UNDEF');
1933         }
1934         if (!defined $keyid) {
1935             $keyid = getfield $clogp, 'Maintainer';
1936         }
1937         unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1938         my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1939         push @sign_cmd, qw(-u),$keyid if defined $keyid;
1940         push @sign_cmd, $tfn->('.tmp');
1941         runcmd_ordryrun @sign_cmd;
1942         if (act_scary()) {
1943             $tagobjfn = $tfn->('.signed.tmp');
1944             runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1945                 $tfn->('.tmp'), $tfn->('.tmp.asc');
1946         }
1947     }
1948
1949     return ($tagobjfn);
1950 }
1951
1952 sub sign_changes ($) {
1953     my ($changesfile) = @_;
1954     if ($sign) {
1955         my @debsign_cmd = @debsign;
1956         push @debsign_cmd, "-k$keyid" if defined $keyid;
1957         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1958         push @debsign_cmd, $changesfile;
1959         runcmd_ordryrun @debsign_cmd;
1960     }
1961 }
1962
1963 sub dopush ($) {
1964     my ($forceflag) = @_;
1965     printdebug "actually entering push\n";
1966     supplementary_message(<<'END');
1967 Push failed, while preparing your push.
1968 You can retry the push, after fixing the problem, if you like.
1969 END
1970     prep_ud();
1971
1972     access_giturl(); # check that success is vaguely likely
1973
1974     my $clogpfn = ".git/dgit/changelog.822.tmp";
1975     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1976
1977     responder_send_file('parsed-changelog', $clogpfn);
1978
1979     my ($clogp, $cversion, $tag, $dscfn) =
1980         push_parse_changelog("$clogpfn");
1981
1982     my $dscpath = "$buildproductsdir/$dscfn";
1983     stat_exists $dscpath or
1984         fail "looked for .dsc $dscfn, but $!;".
1985             " maybe you forgot to build";
1986
1987     responder_send_file('dsc', $dscpath);
1988
1989     push_parse_dsc($dscpath, $dscfn, $cversion);
1990
1991     my $format = getfield $dsc, 'Format';
1992     printdebug "format $format\n";
1993
1994     if (madformat($format)) {
1995         # user might have not used dgit build, so maybe do this now:
1996         commit_quilty_patch();
1997     }
1998
1999     die 'xxx fast forward (should not depend on quilt mode, but will always be needed if we did $split_brain)' if $split_brain;
2000
2001     check_not_dirty();
2002     changedir $ud;
2003     progress "checking that $dscfn corresponds to HEAD";
2004     runcmd qw(dpkg-source -x --),
2005         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
2006     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2007     check_for_vendor_patches() if madformat($dsc->{format});
2008     changedir '../../../..';
2009     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
2010     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
2011     debugcmd "+",@diffcmd;
2012     $!=0; $?=0;
2013     my $r = system @diffcmd;
2014     if ($r) {
2015         if ($r==256) {
2016             fail "$dscfn specifies a different tree to your HEAD commit;".
2017                 " perhaps you forgot to build".
2018                 ($diffopt eq '--exit-code' ? "" :
2019                  " (run with -D to see full diff output)");
2020         } else {
2021             failedcmd @diffcmd;
2022         }
2023     }
2024     my $head = git_rev_parse('HEAD');
2025     if (!$changesfile) {
2026         my $pat = changespat $cversion;
2027         my @cs = glob "$buildproductsdir/$pat";
2028         fail "failed to find unique changes file".
2029             " (looked for $pat in $buildproductsdir);".
2030             " perhaps you need to use dgit -C"
2031             unless @cs==1;
2032         ($changesfile) = @cs;
2033     } else {
2034         $changesfile = "$buildproductsdir/$changesfile";
2035     }
2036
2037     responder_send_file('changes',$changesfile);
2038     responder_send_command("param head $head");
2039     responder_send_command("param csuite $csuite");
2040
2041     if (deliberately_not_fast_forward) {
2042         git_for_each_ref(lrfetchrefs, sub {
2043             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2044             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2045             responder_send_command("previously $rrefname=$objid");
2046             $previously{$rrefname} = $objid;
2047         });
2048     }
2049
2050     my $tfn = sub { ".git/dgit/tag$_[0]"; };
2051     my $tagobjfn;
2052
2053     supplementary_message(<<'END');
2054 Push failed, while signing the tag.
2055 You can retry the push, after fixing the problem, if you like.
2056 END
2057     # If we manage to sign but fail to record it anywhere, it's fine.
2058     if ($we_are_responder) {
2059         $tagobjfn = $tfn->('.signed.tmp');
2060         responder_receive_files('signed-tag', $tagobjfn);
2061     } else {
2062         $tagobjfn =
2063             push_mktag($head,$clogp,$tag,
2064                        $dscpath,
2065                        $changesfile,$changesfile,
2066                        $tfn);
2067     }
2068     supplementary_message(<<'END');
2069 Push failed, *after* signing the tag.
2070 If you want to try again, you should use a new version number.
2071 END
2072
2073     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2074     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2075     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2076
2077     supplementary_message(<<'END');
2078 Push failed, while updating the remote git repository - see messages above.
2079 If you want to try again, you should use a new version number.
2080 END
2081     if (!check_for_git()) {
2082         create_remote_git_repo();
2083     }
2084     runcmd_ordryrun @git, qw(push),access_giturl(),
2085         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2086     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2087
2088     supplementary_message(<<'END');
2089 Push failed, after updating the remote git repository.
2090 If you want to try again, you must use a new version number.
2091 END
2092     if ($we_are_responder) {
2093         my $dryrunsuffix = act_local() ? "" : ".tmp";
2094         responder_receive_files('signed-dsc-changes',
2095                                 "$dscpath$dryrunsuffix",
2096                                 "$changesfile$dryrunsuffix");
2097     } else {
2098         if (act_local()) {
2099             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2100         } else {
2101             progress "[new .dsc left in $dscpath.tmp]";
2102         }
2103         sign_changes $changesfile;
2104     }
2105
2106     supplementary_message(<<END);
2107 Push failed, while uploading package(s) to the archive server.
2108 You can retry the upload of exactly these same files with dput of:
2109   $changesfile
2110 If that .changes file is broken, you will need to use a new version
2111 number for your next attempt at the upload.
2112 END
2113     my $host = access_cfg('upload-host','RETURN-UNDEF');
2114     my @hostarg = defined($host) ? ($host,) : ();
2115     runcmd_ordryrun @dput, @hostarg, $changesfile;
2116     printdone "pushed and uploaded $cversion";
2117
2118     supplementary_message('');
2119     responder_send_command("complete");
2120 }
2121
2122 sub cmd_clone {
2123     parseopts();
2124     notpushing();
2125     my $dstdir;
2126     badusage "-p is not allowed with clone; specify as argument instead"
2127         if defined $package;
2128     if (@ARGV==1) {
2129         ($package) = @ARGV;
2130     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2131         ($package,$isuite) = @ARGV;
2132     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2133         ($package,$dstdir) = @ARGV;
2134     } elsif (@ARGV==3) {
2135         ($package,$isuite,$dstdir) = @ARGV;
2136     } else {
2137         badusage "incorrect arguments to dgit clone";
2138     }
2139     $dstdir ||= "$package";
2140
2141     if (stat_exists $dstdir) {
2142         fail "$dstdir already exists";
2143     }
2144
2145     my $cwd_remove;
2146     if ($rmonerror && !$dryrun_level) {
2147         $cwd_remove= getcwd();
2148         unshift @end, sub { 
2149             return unless defined $cwd_remove;
2150             if (!chdir "$cwd_remove") {
2151                 return if $!==&ENOENT;
2152                 die "chdir $cwd_remove: $!";
2153             }
2154             if (stat $dstdir) {
2155                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2156             } elsif (!grep { $! == $_ }
2157                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2158             } else {
2159                 print STDERR "check whether to remove $dstdir: $!\n";
2160             }
2161         };
2162     }
2163
2164     clone($dstdir);
2165     $cwd_remove = undef;
2166 }
2167
2168 sub branchsuite () {
2169     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2170     if ($branch =~ m#$lbranch_re#o) {
2171         return $1;
2172     } else {
2173         return undef;
2174     }
2175 }
2176
2177 sub fetchpullargs () {
2178     notpushing();
2179     if (!defined $package) {
2180         my $sourcep = parsecontrol('debian/control','debian/control');
2181         $package = getfield $sourcep, 'Source';
2182     }
2183     if (@ARGV==0) {
2184 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2185         if (!$isuite) {
2186             my $clogp = parsechangelog();
2187             $isuite = getfield $clogp, 'Distribution';
2188         }
2189         canonicalise_suite();
2190         progress "fetching from suite $csuite";
2191     } elsif (@ARGV==1) {
2192         ($isuite) = @ARGV;
2193         canonicalise_suite();
2194     } else {
2195         badusage "incorrect arguments to dgit fetch or dgit pull";
2196     }
2197 }
2198
2199 sub cmd_fetch {
2200     parseopts();
2201     fetchpullargs();
2202     fetch();
2203 }
2204
2205 sub cmd_pull {
2206     parseopts();
2207     fetchpullargs();
2208     pull();
2209 }
2210
2211 sub cmd_push {
2212     parseopts();
2213     pushing();
2214     badusage "-p is not allowed with dgit push" if defined $package;
2215     check_not_dirty();
2216     my $clogp = parsechangelog();
2217     $package = getfield $clogp, 'Source';
2218     my $specsuite;
2219     if (@ARGV==0) {
2220     } elsif (@ARGV==1) {
2221         ($specsuite) = (@ARGV);
2222     } else {
2223         badusage "incorrect arguments to dgit push";
2224     }
2225     $isuite = getfield $clogp, 'Distribution';
2226     if ($new_package) {
2227         local ($package) = $existing_package; # this is a hack
2228         canonicalise_suite();
2229     } else {
2230         canonicalise_suite();
2231     }
2232     if (defined $specsuite &&
2233         $specsuite ne $isuite &&
2234         $specsuite ne $csuite) {
2235             fail "dgit push: changelog specifies $isuite ($csuite)".
2236                 " but command line specifies $specsuite";
2237     }
2238     supplementary_message(<<'END');
2239 Push failed, while checking state of the archive.
2240 You can retry the push, after fixing the problem, if you like.
2241 END
2242     if (check_for_git()) {
2243         git_fetch_us();
2244     }
2245     my $forceflag = '';
2246     if (fetch_from_archive()) {
2247         if (is_fast_fwd(lrref(), 'HEAD')) {
2248             # ok
2249         } elsif (deliberately_not_fast_forward) {
2250             $forceflag = '+';
2251         } else {
2252             fail "dgit push: HEAD is not a descendant".
2253                 " of the archive's version.\n".
2254                 "dgit: To overwrite its contents,".
2255                 " use git merge -s ours ".lrref().".\n".
2256                 "dgit: To rewind history, if permitted by the archive,".
2257                 " use --deliberately-not-fast-forward";
2258         }
2259     } else {
2260         $new_package or
2261             fail "package appears to be new in this suite;".
2262                 " if this is intentional, use --new";
2263     }
2264     dopush($forceflag);
2265 }
2266
2267 #---------- remote commands' implementation ----------
2268
2269 sub cmd_remote_push_build_host {
2270     my ($nrargs) = shift @ARGV;
2271     my (@rargs) = @ARGV[0..$nrargs-1];
2272     @ARGV = @ARGV[$nrargs..$#ARGV];
2273     die unless @rargs;
2274     my ($dir,$vsnwant) = @rargs;
2275     # vsnwant is a comma-separated list; we report which we have
2276     # chosen in our ready response (so other end can tell if they
2277     # offered several)
2278     $debugprefix = ' ';
2279     $we_are_responder = 1;
2280     $us .= " (build host)";
2281
2282     pushing();
2283
2284     open PI, "<&STDIN" or die $!;
2285     open STDIN, "/dev/null" or die $!;
2286     open PO, ">&STDOUT" or die $!;
2287     autoflush PO 1;
2288     open STDOUT, ">&STDERR" or die $!;
2289     autoflush STDOUT 1;
2290
2291     $vsnwant //= 1;
2292     ($protovsn) = grep {
2293         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2294     } @rpushprotovsn_support;
2295
2296     fail "build host has dgit rpush protocol versions ".
2297         (join ",", @rpushprotovsn_support).
2298         " but invocation host has $vsnwant"
2299         unless defined $protovsn;
2300
2301     responder_send_command("dgit-remote-push-ready $protovsn");
2302
2303     changedir $dir;
2304     &cmd_push;
2305 }
2306
2307 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2308 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2309 #     a good error message)
2310
2311 our $i_tmp;
2312
2313 sub i_cleanup {
2314     local ($@, $?);
2315     my $report = i_child_report();
2316     if (defined $report) {
2317         printdebug "($report)\n";
2318     } elsif ($i_child_pid) {
2319         printdebug "(killing build host child $i_child_pid)\n";
2320         kill 15, $i_child_pid;
2321     }
2322     if (defined $i_tmp && !defined $initiator_tempdir) {
2323         changedir "/";
2324         eval { rmtree $i_tmp; };
2325     }
2326 }
2327
2328 END { i_cleanup(); }
2329
2330 sub i_method {
2331     my ($base,$selector,@args) = @_;
2332     $selector =~ s/\-/_/g;
2333     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2334 }
2335
2336 sub cmd_rpush {
2337     pushing();
2338     my $host = nextarg;
2339     my $dir;
2340     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2341         $host = $1;
2342         $dir = $'; #';
2343     } else {
2344         $dir = nextarg;
2345     }
2346     $dir =~ s{^-}{./-};
2347     my @rargs = ($dir);
2348     push @rargs, join ",", @rpushprotovsn_support;
2349     my @rdgit;
2350     push @rdgit, @dgit;
2351     push @rdgit, @ropts;
2352     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2353     push @rdgit, @ARGV;
2354     my @cmd = (@ssh, $host, shellquote @rdgit);
2355     debugcmd "+",@cmd;
2356
2357     if (defined $initiator_tempdir) {
2358         rmtree $initiator_tempdir;
2359         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2360         $i_tmp = $initiator_tempdir;
2361     } else {
2362         $i_tmp = tempdir();
2363     }
2364     $i_child_pid = open2(\*RO, \*RI, @cmd);
2365     changedir $i_tmp;
2366     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2367     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2368     $supplementary_message = '' unless $protovsn >= 3;
2369     for (;;) {
2370         my ($icmd,$iargs) = initiator_expect {
2371             m/^(\S+)(?: (.*))?$/;
2372             ($1,$2);
2373         };
2374         i_method "i_resp", $icmd, $iargs;
2375     }
2376 }
2377
2378 sub i_resp_progress ($) {
2379     my ($rhs) = @_;
2380     my $msg = protocol_read_bytes \*RO, $rhs;
2381     progress $msg;
2382 }
2383
2384 sub i_resp_supplementary_message ($) {
2385     my ($rhs) = @_;
2386     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2387 }
2388
2389 sub i_resp_complete {
2390     my $pid = $i_child_pid;
2391     $i_child_pid = undef; # prevents killing some other process with same pid
2392     printdebug "waiting for build host child $pid...\n";
2393     my $got = waitpid $pid, 0;
2394     die $! unless $got == $pid;
2395     die "build host child failed $?" if $?;
2396
2397     i_cleanup();
2398     printdebug "all done\n";
2399     exit 0;
2400 }
2401
2402 sub i_resp_file ($) {
2403     my ($keyword) = @_;
2404     my $localname = i_method "i_localname", $keyword;
2405     my $localpath = "$i_tmp/$localname";
2406     stat_exists $localpath and
2407         badproto \*RO, "file $keyword ($localpath) twice";
2408     protocol_receive_file \*RO, $localpath;
2409     i_method "i_file", $keyword;
2410 }
2411
2412 our %i_param;
2413
2414 sub i_resp_param ($) {
2415     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2416     $i_param{$1} = $2;
2417 }
2418
2419 sub i_resp_previously ($) {
2420     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2421         or badproto \*RO, "bad previously spec";
2422     my $r = system qw(git check-ref-format), $1;
2423     die "bad previously ref spec ($r)" if $r;
2424     $previously{$1} = $2;
2425 }
2426
2427 our %i_wanted;
2428
2429 sub i_resp_want ($) {
2430     my ($keyword) = @_;
2431     die "$keyword ?" if $i_wanted{$keyword}++;
2432     my @localpaths = i_method "i_want", $keyword;
2433     printdebug "[[  $keyword @localpaths\n";
2434     foreach my $localpath (@localpaths) {
2435         protocol_send_file \*RI, $localpath;
2436     }
2437     print RI "files-end\n" or die $!;
2438 }
2439
2440 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2441
2442 sub i_localname_parsed_changelog {
2443     return "remote-changelog.822";
2444 }
2445 sub i_file_parsed_changelog {
2446     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2447         push_parse_changelog "$i_tmp/remote-changelog.822";
2448     die if $i_dscfn =~ m#/|^\W#;
2449 }
2450
2451 sub i_localname_dsc {
2452     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2453     return $i_dscfn;
2454 }
2455 sub i_file_dsc { }
2456
2457 sub i_localname_changes {
2458     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2459     $i_changesfn = $i_dscfn;
2460     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2461     return $i_changesfn;
2462 }
2463 sub i_file_changes { }
2464
2465 sub i_want_signed_tag {
2466     printdebug Dumper(\%i_param, $i_dscfn);
2467     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2468         && defined $i_param{'csuite'}
2469         or badproto \*RO, "premature desire for signed-tag";
2470     my $head = $i_param{'head'};
2471     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2472
2473     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2474     $csuite = $&;
2475     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2476
2477     my $tagobjfn =
2478         push_mktag $head, $i_clogp, $i_tag,
2479             $i_dscfn,
2480             $i_changesfn, 'remote changes',
2481             sub { "tag$_[0]"; };
2482
2483     return $tagobjfn;
2484 }
2485
2486 sub i_want_signed_dsc_changes {
2487     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2488     sign_changes $i_changesfn;
2489     return ($i_dscfn, $i_changesfn);
2490 }
2491
2492 #---------- building etc. ----------
2493
2494 our $version;
2495 our $sourcechanges;
2496 our $dscfn;
2497
2498 #----- `3.0 (quilt)' handling -----
2499
2500 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2501
2502 sub quiltify_dpkg_commit ($$$;$) {
2503     my ($patchname,$author,$msg, $xinfo) = @_;
2504     $xinfo //= '';
2505
2506     mkpath '.git/dgit';
2507     my $descfn = ".git/dgit/quilt-description.tmp";
2508     open O, '>', $descfn or die "$descfn: $!";
2509     $msg =~ s/\s+$//g;
2510     $msg =~ s/\n/\n /g;
2511     $msg =~ s/^\s+$/ ./mg;
2512     print O <<END or die $!;
2513 Description: $msg
2514 Author: $author
2515 $xinfo
2516 ---
2517
2518 END
2519     close O or die $!;
2520
2521     {
2522         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2523         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2524         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2525         runcmd @dpkgsource, qw(--commit .), $patchname;
2526     }
2527 }
2528
2529 sub quiltify_trees_differ ($$;$$) {
2530     my ($x,$y,$finegrained,$ignorenamesr) = @_;
2531     # returns true iff the two tree objects differ other than in debian/
2532     # with $finegrained,
2533     # returns bitmask 01 - differ in upstream files except .gitignore
2534     #                 02 - differ in .gitignore
2535     # if $ignorenamesr is defined, $ingorenamesr->{$fn}
2536     #  is set for each modified .gitignore filename $fn
2537     local $/=undef;
2538     my @cmd = (@git, qw(diff-tree --name-only -z));
2539     push @cmd, qw(-r) if $finegrained;
2540     push @cmd, $x, $y;
2541     my $diffs= cmdoutput @cmd;
2542     my $r = 0;
2543     foreach my $f (split /\0/, $diffs) {
2544         next if $f =~ m#^debian(?:/.*)?$#s;
2545         my $isignore = $f =~ m#^(?:.*/)?.gitignore$#s;
2546         $r |= $isignore ? 02 : 01;
2547         $ignorenamesr->{$f}=1 if $ignorenamesr && $isignore;
2548     }
2549     printdebug "quiltify_trees_differ $x $y => $r\n";
2550     return $r;
2551 }
2552
2553 sub quiltify_tree_sentinelfiles ($) {
2554     # lists the `sentinel' files present in the tree
2555     my ($x) = @_;
2556     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2557         qw(-- debian/rules debian/control);
2558     $r =~ s/\n/,/g;
2559     return $r;
2560                                  }
2561
2562 sub quiltify_splitbrain_needed () {
2563     if (!$split_brain) {
2564         progress "creating dgit view";
2565         runcmd @git, qw(checkout -q -b dgit-view);
2566         $split_brain = 1;
2567     }
2568 }
2569
2570 sub quiltify_splitbrain ($$$$$$) {
2571     my ($clogp, $unapplied, $headref, $diffbits,
2572         $editedignores, $cachekey) = @_;
2573     if ($quilt_mode !~ m/gbp|dpm/) {
2574         # treat .gitignore just like any other upstream file
2575         $diffbits = { %$diffbits };
2576         $_ = !!$_ foreach values %$diffbits;
2577     }
2578     # We would like any commits we generate to be reproducible
2579     my @authline = clogp_authline($clogp);
2580     local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2581     local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2582     local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2583         
2584     if ($quilt_mode =~ m/gbp|unapplied/ &&
2585         ($diffbits->{H2O} & 01)) {
2586         my $msg =
2587  "--quilt=$quilt_mode specified, implying patches-unapplied git tree\n".
2588  " but git tree differs from orig in upstream files.";
2589         if (!stat_exists "debian/patches") {
2590             $msg .=
2591  "\n ... debian/patches is missing; perhaps this is a patch queue branch?";
2592         }  
2593         fail $msg;
2594     }
2595     if ($quilt_mode =~ m/gbp|unapplied/ &&
2596         ($diffbits->{O2A} & 01)) { # some patches
2597         quiltify_splitbrain_needed();
2598         progress "creating patches-applied version using gbp pq";
2599         runcmd shell_cmd 'exec >/dev/null', @gbp, qw(pq import);
2600         # gbp pq import creates a fresh branch; push back to dgit-view
2601         runcmd @git, qw(update-ref refs/heads/dgit-view HEAD);
2602         runcmd @git, qw(checkout -q dgit-view);
2603     }
2604     if (($diffbits->{H2O} & 02) && # user has modified .gitignore
2605         !($diffbits->{O2A} & 02)) { # patches do not change .gitignore
2606         quiltify_splitbrain_needed();
2607         progress "creating patch to represent .gitignore changes";
2608         ensuredir "debian/patches";
2609         my $gipatch = "debian/patches/auto-gitignore";
2610         open GIPATCH, ">>", "$gipatch" or die "$gipatch: $!";
2611         stat GIPATCH or die "$gipatch: $!";
2612         fail "$gipatch already exists; but want to create it".
2613             " to record .gitignore changes" if (stat _)[7];
2614         print GIPATCH <<END or die "$gipatch: $!";
2615 Subject: Update .gitignore from Debian packaging branch
2616
2617 The Debian packaging git branch contains these updates to the upstream
2618 .gitignore file(s).  This patch is autogenerated, to provide these
2619 updates to users of the official Debian archive view of the package.
2620
2621 [dgit version $our_version]
2622 ---
2623 END
2624         close GIPATCH or die "$gipatch: $!";
2625         runcmd shell_cmd "exec >>$gipatch", @git, qw(diff),
2626             $unapplied, $headref, "--", sort keys %$editedignores;
2627         open SERIES, "+>>", "debian/patches/series" or die $!;
2628         defined seek SERIES, -1, 2 or $!==EINVAL or die $!;
2629         my $newline;
2630         defined read SERIES, $newline, 1 or die $!;
2631         print SERIES "\n" or die $! unless $newline eq "\n";
2632         print SERIES "auto-gitignore\n" or die $!;
2633         close SERIES or die  $!;
2634         runcmd @git, qw(add -- debian/patches/series), $gipatch;
2635         commit_admin "Commit patch to update .gitignore";
2636     }
2637
2638     my $dgitview = git_rev_parse 'refs/heads/dgit-view';
2639
2640     changedir '../../../..';
2641     ensuredir ".git/logs/refs/dgit-intern";
2642     my $makelogfh = new IO::File ".git/logs/refs/$splitbraincache", '>>'
2643       or die $!;
2644     runcmd @git, qw(update-ref -m), $cachekey, "refs/$splitbraincache",
2645         $dgitview;
2646
2647     progress "created dgit view (commit id $dgitview)";
2648
2649     changedir '.git/dgit/unpack/work';
2650 }
2651
2652 sub quiltify ($$$$) {
2653     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2654
2655     # Quilt patchification algorithm
2656     #
2657     # We search backwards through the history of the main tree's HEAD
2658     # (T) looking for a start commit S whose tree object is identical
2659     # to to the patch tip tree (ie the tree corresponding to the
2660     # current dpkg-committed patch series).  For these purposes
2661     # `identical' disregards anything in debian/ - this wrinkle is
2662     # necessary because dpkg-source treates debian/ specially.
2663     #
2664     # We can only traverse edges where at most one of the ancestors'
2665     # trees differs (in changes outside in debian/).  And we cannot
2666     # handle edges which change .pc/ or debian/patches.  To avoid
2667     # going down a rathole we avoid traversing edges which introduce
2668     # debian/rules or debian/control.  And we set a limit on the
2669     # number of edges we are willing to look at.
2670     #
2671     # If we succeed, we walk forwards again.  For each traversed edge
2672     # PC (with P parent, C child) (starting with P=S and ending with
2673     # C=T) to we do this:
2674     #  - git checkout C
2675     #  - dpkg-source --commit with a patch name and message derived from C
2676     # After traversing PT, we git commit the changes which
2677     # should be contained within debian/patches.
2678
2679     # The search for the path S..T is breadth-first.  We maintain a
2680     # todo list containing search nodes.  A search node identifies a
2681     # commit, and looks something like this:
2682     #  $p = {
2683     #      Commit => $git_commit_id,
2684     #      Child => $c,                          # or undef if P=T
2685     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2686     #      Nontrivial => true iff $p..$c has relevant changes
2687     #  };
2688
2689     my @todo;
2690     my @nots;
2691     my $sref_S;
2692     my $max_work=100;
2693     my %considered; # saves being exponential on some weird graphs
2694
2695     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2696
2697     my $not = sub {
2698         my ($search,$whynot) = @_;
2699         printdebug " search NOT $search->{Commit} $whynot\n";
2700         $search->{Whynot} = $whynot;
2701         push @nots, $search;
2702         no warnings qw(exiting);
2703         next;
2704     };
2705
2706     push @todo, {
2707         Commit => $target,
2708     };
2709
2710     while (@todo) {
2711         my $c = shift @todo;
2712         next if $considered{$c->{Commit}}++;
2713
2714         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2715
2716         printdebug "quiltify investigate $c->{Commit}\n";
2717
2718         # are we done?
2719         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2720             printdebug " search finished hooray!\n";
2721             $sref_S = $c;
2722             last;
2723         }
2724
2725         if ($quilt_mode eq 'nofix') {
2726             fail "quilt fixup required but quilt mode is \`nofix'\n".
2727                 "HEAD commit $c->{Commit} differs from tree implied by ".
2728                 " debian/patches (tree object $oldtiptree)";
2729         }
2730         if ($quilt_mode eq 'smash') {
2731             printdebug " search quitting smash\n";
2732             last;
2733         }
2734
2735         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2736         $not->($c, "has $c_sentinels not $t_sentinels")
2737             if $c_sentinels ne $t_sentinels;
2738
2739         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2740         $commitdata =~ m/\n\n/;
2741         $commitdata =~ $`;
2742         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2743         @parents = map { { Commit => $_, Child => $c } } @parents;
2744
2745         $not->($c, "root commit") if !@parents;
2746
2747         foreach my $p (@parents) {
2748             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2749         }
2750         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2751         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2752
2753         foreach my $p (@parents) {
2754             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2755
2756             my @cmd= (@git, qw(diff-tree -r --name-only),
2757                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2758             my $patchstackchange = cmdoutput @cmd;
2759             if (length $patchstackchange) {
2760                 $patchstackchange =~ s/\n/,/g;
2761                 $not->($p, "changed $patchstackchange");
2762             }
2763
2764             printdebug " search queue P=$p->{Commit} ",
2765                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2766             push @todo, $p;
2767         }
2768     }
2769
2770     if (!$sref_S) {
2771         printdebug "quiltify want to smash\n";
2772
2773         my $abbrev = sub {
2774             my $x = $_[0]{Commit};
2775             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2776             return $x;
2777         };
2778         my $reportnot = sub {
2779             my ($notp) = @_;
2780             my $s = $abbrev->($notp);
2781             my $c = $notp->{Child};
2782             $s .= "..".$abbrev->($c) if $c;
2783             $s .= ": ".$notp->{Whynot};
2784             return $s;
2785         };
2786         if ($quilt_mode eq 'linear') {
2787             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2788             foreach my $notp (@nots) {
2789                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2790             }
2791             print STDERR "$us: $_\n" foreach @$failsuggestion;
2792             fail "quilt fixup naive history linearisation failed.\n".
2793  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2794         } elsif ($quilt_mode eq 'smash') {
2795         } elsif ($quilt_mode eq 'auto') {
2796             progress "quilt fixup cannot be linear, smashing...";
2797         } else {
2798             die "$quilt_mode ?";
2799         }
2800
2801         my $time = time;
2802         my $ncommits = 3;
2803         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2804
2805         quiltify_dpkg_commit "auto-$version-$target-$time",
2806             (getfield $clogp, 'Maintainer'),
2807             "Automatically generated patch ($clogp->{Version})\n".
2808             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2809         return;
2810     }
2811
2812     progress "quiltify linearisation planning successful, executing...";
2813
2814     for (my $p = $sref_S;
2815          my $c = $p->{Child};
2816          $p = $p->{Child}) {
2817         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2818         next unless $p->{Nontrivial};
2819
2820         my $cc = $c->{Commit};
2821
2822         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2823         $commitdata =~ m/\n\n/ or die "$c ?";
2824         $commitdata = $`;
2825         my $msg = $'; #';
2826         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2827         my $author = $1;
2828
2829         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2830
2831         my $title = $1;
2832         my $patchname = $title;
2833         $patchname =~ s/[.:]$//;
2834         $patchname =~ y/ A-Z/-a-z/;
2835         $patchname =~ y/-a-z0-9_.+=~//cd;
2836         $patchname =~ s/^\W/x-$&/;
2837         $patchname = substr($patchname,0,40);
2838         my $index;
2839         for ($index='';
2840              stat "debian/patches/$patchname$index";
2841              $index++) { }
2842         $!==ENOENT or die "$patchname$index $!";
2843
2844         runcmd @git, qw(checkout -q), $cc;
2845
2846         # We use the tip's changelog so that dpkg-source doesn't
2847         # produce complaining messages from dpkg-parsechangelog.  None
2848         # of the information dpkg-source gets from the changelog is
2849         # actually relevant - it gets put into the original message
2850         # which dpkg-source provides our stunt editor, and then
2851         # overwritten.
2852         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2853
2854         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2855             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2856
2857         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2858     }
2859
2860     runcmd @git, qw(checkout -q master);
2861 }
2862
2863 sub build_maybe_quilt_fixup () {
2864     my ($format,$fopts) = get_source_format;
2865     return unless madformat $format;
2866     # sigh
2867
2868     check_for_vendor_patches();
2869
2870     my $clogp = parsechangelog();
2871     my $headref = git_rev_parse('HEAD');
2872
2873     prep_ud();
2874     changedir $ud;
2875
2876     my $upstreamversion=$version;
2877     $upstreamversion =~ s/-[^-]*$//;
2878
2879     if ($fopts->{'single-debian-patch'}) {
2880         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2881     } else {
2882         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2883     }
2884
2885     die 'bug' if $split_brain && !$need_split_build_invocation;
2886
2887     changedir '../../../..';
2888     runcmd_ordryrun_local
2889         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2890 }
2891
2892 sub quilt_fixup_mkwork ($) {
2893     my ($headref) = @_;
2894
2895     mkdir "work" or die $!;
2896     changedir "work";
2897     mktree_in_ud_here();
2898     runcmd @git, qw(reset -q --hard), $headref;
2899 }
2900
2901 sub quilt_fixup_linkorigs ($$) {
2902     my ($upstreamversion, $fn) = @_;
2903     # calls $fn->($leafname);
2904
2905     foreach my $f (<../../../../*>) { #/){
2906         my $b=$f; $b =~ s{.*/}{};
2907         {
2908             local ($debuglevel) = $debuglevel-1;
2909             printdebug "QF linkorigs $b, $f ?\n";
2910         }
2911         next unless is_orig_file $b, srcfn $upstreamversion,'';
2912         printdebug "QF linkorigs $b, $f Y\n";
2913         link_ltarget $f, $b or die "$b $!";
2914         $fn->($b);
2915     }
2916 }
2917
2918 sub quilt_fixup_delete_pc () {
2919     runcmd @git, qw(rm -rqf .pc);
2920     commit_admin "Commit removal of .pc (quilt series tracking data)";
2921 }
2922
2923 sub quilt_fixup_singlepatch ($$$) {
2924     my ($clogp, $headref, $upstreamversion) = @_;
2925
2926     progress "starting quiltify (single-debian-patch)";
2927
2928     # dpkg-source --commit generates new patches even if
2929     # single-debian-patch is in debian/source/options.  In order to
2930     # get it to generate debian/patches/debian-changes, it is
2931     # necessary to build the source package.
2932
2933     quilt_fixup_linkorigs($upstreamversion, sub { });
2934     quilt_fixup_mkwork($headref);
2935
2936     rmtree("debian/patches");
2937
2938     runcmd @dpkgsource, qw(-b .);
2939     chdir "..";
2940     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2941     rename srcfn("$upstreamversion", "/debian/patches"), 
2942            "work/debian/patches";
2943
2944     chdir "work";
2945     commit_quilty_patch();
2946
2947     
2948 }
2949
2950 sub quilt_fixup_multipatch ($$$) {
2951     my ($clogp, $headref, $upstreamversion) = @_;
2952
2953     progress "starting quiltify (multiple patches, $quilt_mode mode)";
2954
2955     # Our objective is:
2956     #  - honour any existing .pc in case it has any strangeness
2957     #  - determine the git commit corresponding to the tip of
2958     #    the patch stack (if there is one)
2959     #  - if there is such a git commit, convert each subsequent
2960     #    git commit into a quilt patch with dpkg-source --commit
2961     #  - otherwise convert all the differences in the tree into
2962     #    a single git commit
2963     #
2964     # To do this we:
2965
2966     # Our git tree doesn't necessarily contain .pc.  (Some versions of
2967     # dgit would include the .pc in the git tree.)  If there isn't
2968     # one, we need to generate one by unpacking the patches that we
2969     # have.
2970     #
2971     # We first look for a .pc in the git tree.  If there is one, we
2972     # will use it.  (This is not the normal case.)
2973     #
2974     # Otherwise need to regenerate .pc so that dpkg-source --commit
2975     # can work.  We do this as follows:
2976     #     1. Collect all relevant .orig from parent directory
2977     #     2. Generate a debian.tar.gz out of
2978     #         debian/{patches,rules,source/format,source/options}
2979     #     3. Generate a fake .dsc containing just these fields:
2980     #          Format Source Version Files
2981     #     4. Extract the fake .dsc
2982     #        Now the fake .dsc has a .pc directory.
2983     # (In fact we do this in every case, because in future we will
2984     # want to search for a good base commit for generating patches.)
2985     #
2986     # Then we can actually do the dpkg-source --commit
2987     #     1. Make a new working tree with the same object
2988     #        store as our main tree and check out the main
2989     #        tree's HEAD.
2990     #     2. Copy .pc from the fake's extraction, if necessary
2991     #     3. Run dpkg-source --commit
2992     #     4. If the result has changes to debian/, then
2993     #          - git-add them them
2994     #          - git-add .pc if we had a .pc in-tree
2995     #          - git-commit
2996     #     5. If we had a .pc in-tree, delete it, and git-commit
2997     #     6. Back in the main tree, fast forward to the new HEAD
2998
2999     # Another situation we may have to cope with is gbp-style
3000     # patches-unapplied trees.
3001     #
3002     # We would want to detect these, so we know to escape into
3003     # quilt_fixup_gbp.  However, this is in general not possible.
3004     # Consider a package with a one patch which the dgit user reverts
3005     # (with git-revert or the moral equivalent).
3006     #
3007     # That is indistinguishable in contents from a patches-unapplied
3008     # tree.  And looking at the history to distinguish them is not
3009     # useful because the user might have made a confusing-looking git
3010     # history structure (which ought to produce an error if dgit can't
3011     # cope, not a silent reintroduction of an unwanted patch).
3012     #
3013     # So gbp users will have to pass an option.  But we can usually
3014     # detect their failure to do so: if the tree is not a clean
3015     # patches-applied tree, quilt linearisation fails, but the tree
3016     # _is_ a clean patches-unapplied tree, we can suggest that maybe
3017     # they want --quilt=unapplied.
3018     #
3019     # To help detect this, when we are extracting the fake dsc, we
3020     # first extract it with --skip-patches, and then apply the patches
3021     # afterwards with dpkg-source --before-build.  That lets us save a
3022     # tree object corresponding to .origs.
3023
3024     my $fakeversion="$upstreamversion-~~DGITFAKE";
3025
3026     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
3027     print $fakedsc <<END or die $!;
3028 Format: 3.0 (quilt)
3029 Source: $package
3030 Version: $fakeversion
3031 Files:
3032 END
3033
3034     my $dscaddfile=sub {
3035         my ($b) = @_;
3036         
3037         my $md = new Digest::MD5;
3038
3039         my $fh = new IO::File $b, '<' or die "$b $!";
3040         stat $fh or die $!;
3041         my $size = -s _;
3042
3043         $md->addfile($fh);
3044         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
3045     };
3046
3047     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
3048
3049     my @files=qw(debian/source/format debian/rules
3050                  debian/control debian/changelog);
3051     foreach my $maybe (qw(debian/patches debian/source/options
3052                           debian/tests/control)) {
3053         next unless stat_exists "../../../$maybe";
3054         push @files, $maybe;
3055     }
3056
3057     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
3058     runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
3059
3060     $dscaddfile->($debtar);
3061     close $fakedsc or die $!;
3062
3063     my $splitbrain_cachekey;
3064     if (quiltmode_splitbrain()) {
3065         # we look in the reflog of dgit-intern/quilt-cache
3066         # we look for an entry whose message is the key for the cache lookup
3067         my @cachekey = (qw(dgit), $our_version);
3068         push @cachekey, $upstreamversion;
3069         push @cachekey, $quilt_mode;
3070         push @cachekey, $headref;
3071
3072         push @cachekey, hashfile('fake.dsc');
3073
3074         my $srcshash = Digest::SHA->new(256);
3075         my %sfs = ( %INC, '$0(dgit)' => $0 );
3076         foreach my $sfk (sort keys %sfs) {
3077             $srcshash->add($sfk,"  ");
3078             $srcshash->add(hashfile($sfs{$sfk}));
3079             $srcshash->add("\n");
3080         }
3081         push @cachekey, $srcshash->hexdigest();
3082         $splitbrain_cachekey = "@cachekey";
3083
3084         my @cmd = (@git, qw(reflog), '--pretty=format:%H %gs',
3085                    $splitbraincache);
3086         printdebug "splitbrain cachekey $splitbrain_cachekey\n";
3087         debugcmd "|(probably)",@cmd;
3088         my $child = open GC, "-|";  defined $child or die $!;
3089         if (!$child) {
3090             chdir '../../..' or die $!;
3091             if (!stat ".git/logs/refs/$splitbraincache") {
3092                 $! == ENOENT or die $!;
3093                 printdebug ">(no reflog)\n";
3094                 exit 0;
3095             }
3096             exec @cmd; die $!;
3097         }
3098         while (<GC>) {
3099             chomp;
3100             printdebug ">| ", $_, "\n" if $debuglevel > 1;
3101             next unless m/^(\w+) (\S.*\S)$/ && $2 eq $splitbrain_cachekey;
3102             
3103             my $cachehit = $1;
3104             quilt_fixup_mkwork($headref);
3105             if ($cachehit ne $headref) {
3106                 progress "quilt fixup ($quilt_mode mode) found cached tree";
3107                 runcmd @git, qw(checkout -q -b dgit-view), $cachehit;
3108                 $split_brain = 1;
3109                 return;
3110             }
3111             progress "quilt fixup ($quilt_mode mode)".
3112               " found cached indication that no changes needed";
3113             return;
3114         }
3115         die $! if GC->error;
3116         failedcmd unless close GC;
3117
3118         printdebug "splitbrain cache miss\n";
3119     }
3120
3121     runcmd qw(sh -ec),
3122         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
3123
3124     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
3125     rename $fakexdir, "fake" or die "$fakexdir $!";
3126
3127     changedir 'fake';
3128
3129     remove_stray_gits();
3130     mktree_in_ud_here();
3131
3132     rmtree '.pc';
3133
3134     runcmd @git, qw(add -Af .);
3135     my $unapplied=git_write_tree();
3136     printdebug "fake orig tree object $unapplied\n";
3137
3138     ensuredir '.pc';
3139
3140     runcmd qw(sh -ec),
3141         'exec dpkg-source --before-build . >/dev/null';
3142
3143     changedir '..';
3144
3145     quilt_fixup_mkwork($headref);
3146
3147     my $mustdeletepc=0;
3148     if (stat_exists ".pc") {
3149         -d _ or die;
3150         progress "Tree already contains .pc - will use it then delete it.";
3151         $mustdeletepc=1;
3152     } else {
3153         rename '../fake/.pc','.pc' or die $!;
3154     }
3155
3156     changedir '../fake';
3157     rmtree '.pc';
3158     runcmd @git, qw(add -Af .);
3159     my $oldtiptree=git_write_tree();
3160     printdebug "fake o+d/p tree object $unapplied\n";
3161     changedir '../work';
3162
3163
3164     # We calculate some guesswork now about what kind of tree this might
3165     # be.  This is mostly for error reporting.
3166
3167     my %editedignores;
3168     my $diffbits = {
3169         # H = user's HEAD
3170         # O = orig, without patches applied
3171         # A = "applied", ie orig with H's debian/patches applied
3172         H2O => quiltify_trees_differ($headref,  $unapplied, 1,\%editedignores),
3173         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3174         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3175     };
3176
3177     my @dl;
3178     foreach my $b (qw(01 02)) {
3179         foreach my $v (qw(H2O O2A H2A)) {
3180             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3181         }
3182     }
3183     printdebug "differences \@dl @dl.\n";
3184
3185     progress sprintf
3186 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3187 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3188                              $dl[0], $dl[1],              $dl[3], $dl[4],
3189                                  $dl[2],                     $dl[5];
3190
3191     my @failsuggestion;
3192     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3193         push @failsuggestion, "This might be a patches-unapplied branch.";
3194     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3195         push @failsuggestion, "This might be a patches-applied branch.";
3196     }
3197     push @failsuggestion, "Maybe you need to specify one of".
3198         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3199
3200     if (quiltmode_splitbrain()) {
3201         quiltify_splitbrain($clogp, $unapplied, $headref,
3202                             $diffbits, \%editedignores,
3203                             $splitbrain_cachekey);
3204         return;
3205     }
3206
3207     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3208
3209     if (!open P, '>>', ".pc/applied-patches") {
3210         $!==&ENOENT or die $!;
3211     } else {
3212         close P;
3213     }
3214
3215     commit_quilty_patch();
3216
3217     if ($mustdeletepc) {
3218         quilt_fixup_delete_pc();
3219     }
3220 }
3221
3222 sub quilt_fixup_editor () {
3223     my $descfn = $ENV{$fakeeditorenv};
3224     my $editing = $ARGV[$#ARGV];
3225     open I1, '<', $descfn or die "$descfn: $!";
3226     open I2, '<', $editing or die "$editing: $!";
3227     unlink $editing or die "$editing: $!";
3228     open O, '>', $editing or die "$editing: $!";
3229     while (<I1>) { print O or die $!; } I1->error and die $!;
3230     my $copying = 0;
3231     while (<I2>) {
3232         $copying ||= m/^\-\-\- /;
3233         next unless $copying;
3234         print O or die $!;
3235     }
3236     I2->error and die $!;
3237     close O or die $1;
3238     exit 0;
3239 }
3240
3241 sub maybe_apply_patches_dirtily () {
3242     return unless $quilt_mode =~ m/gbp|unapplied/;
3243     print STDERR <<END or die $!;
3244
3245 dgit: Building, or cleaning with rules target, in patches-unapplied tree.
3246 dgit: Have to apply the patches - making the tree dirty.
3247 dgit: (Consider specifying --clean=git and (or) using dgit sbuild.)
3248
3249 END
3250     $patches_applied_dirtily = 01;
3251     $patches_applied_dirtily |= 02 unless stat_exists '.pc';
3252     runcmd qw(dpkg-source --before-build .);
3253 }
3254
3255 sub maybe_unapply_patches_again () {
3256     progress "dgit: Unapplying patches again to tidy up the tree."
3257         if $patches_applied_dirtily;
3258     runcmd qw(dpkg-source --after-build .)
3259         if $patches_applied_dirtily & 01;
3260     rmtree '.pc'
3261         if $patches_applied_dirtily & 02;
3262 }
3263
3264 #----- other building -----
3265
3266 our $clean_using_builder;
3267 # ^ tree is to be cleaned by dpkg-source's builtin idea that it should
3268 #   clean the tree before building (perhaps invoked indirectly by
3269 #   whatever we are using to run the build), rather than separately
3270 #   and explicitly by us.
3271
3272 sub clean_tree () {
3273     return if $clean_using_builder;
3274     if ($cleanmode eq 'dpkg-source') {
3275         maybe_apply_patches_dirtily();
3276         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3277     } elsif ($cleanmode eq 'dpkg-source-d') {
3278         maybe_apply_patches_dirtily();
3279         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3280     } elsif ($cleanmode eq 'git') {
3281         runcmd_ordryrun_local @git, qw(clean -xdf);
3282     } elsif ($cleanmode eq 'git-ff') {
3283         runcmd_ordryrun_local @git, qw(clean -xdff);
3284     } elsif ($cleanmode eq 'check') {
3285         my $leftovers = cmdoutput @git, qw(clean -xdn);
3286         if (length $leftovers) {
3287             print STDERR $leftovers, "\n" or die $!;
3288             fail "tree contains uncommitted files and --clean=check specified";
3289         }
3290     } elsif ($cleanmode eq 'none') {
3291     } else {
3292         die "$cleanmode ?";
3293     }
3294 }
3295
3296 sub cmd_clean () {
3297     badusage "clean takes no additional arguments" if @ARGV;
3298     notpushing();
3299     clean_tree();
3300     maybe_unapply_patches_again();
3301 }
3302
3303 sub build_prep () {
3304     notpushing();
3305     badusage "-p is not allowed when building" if defined $package;
3306     check_not_dirty();
3307     clean_tree();
3308     my $clogp = parsechangelog();
3309     $isuite = getfield $clogp, 'Distribution';
3310     $package = getfield $clogp, 'Source';
3311     $version = getfield $clogp, 'Version';
3312     build_maybe_quilt_fixup();
3313     if ($rmchanges) {
3314         my $pat = changespat $version;
3315         foreach my $f (glob "$buildproductsdir/$pat") {
3316             if (act_local()) {
3317                 unlink $f or fail "remove old changes file $f: $!";
3318             } else {
3319                 progress "would remove $f";
3320             }
3321         }
3322     }
3323 }
3324
3325 sub changesopts_initial () {
3326     my @opts =@changesopts[1..$#changesopts];
3327 }
3328
3329 sub changesopts_version () {
3330     if (!defined $changes_since_version) {
3331         my @vsns = archive_query('archive_query');
3332         my @quirk = access_quirk();
3333         if ($quirk[0] eq 'backports') {
3334             local $isuite = $quirk[2];
3335             local $csuite;
3336             canonicalise_suite();
3337             push @vsns, archive_query('archive_query');
3338         }
3339         if (@vsns) {
3340             @vsns = map { $_->[0] } @vsns;
3341             @vsns = sort { -version_compare($a, $b) } @vsns;
3342             $changes_since_version = $vsns[0];
3343             progress "changelog will contain changes since $vsns[0]";
3344         } else {
3345             $changes_since_version = '_';
3346             progress "package seems new, not specifying -v<version>";
3347         }
3348     }
3349     if ($changes_since_version ne '_') {
3350         return ("-v$changes_since_version");
3351     } else {
3352         return ();
3353     }
3354 }
3355
3356 sub changesopts () {
3357     return (changesopts_initial(), changesopts_version());
3358 }
3359
3360 sub massage_dbp_args ($;$) {
3361     my ($cmd,$xargs) = @_;
3362     # We need to:
3363     #
3364     #  - if we're going to split the source build out so we can
3365     #    do strange things to it, massage the arguments to dpkg-buildpackage
3366     #    so that the main build doessn't build source (or add an argument
3367     #    to stop it building source by default).
3368     #
3369     #  - add -nc to stop dpkg-source cleaning the source tree,
3370     #    unless we're not doing a split build and want dpkg-source
3371     #    as cleanmode, in which case we can do nothing
3372     #
3373     # return values:
3374     #    0 - source will NOT need to be built separately by caller
3375     #   +1 - source will need to be built separately by caller
3376     #   +2 - source will need to be built separately by caller AND
3377     #        dpkg-buildpackage should not in fact be run at all!
3378     debugcmd '#massaging#', @$cmd if $debuglevel>1;
3379 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3380     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3381         $clean_using_builder = 1;
3382         return 0;
3383     }
3384     # -nc has the side effect of specifying -b if nothing else specified
3385     # and some combinations of -S, -b, et al, are errors, rather than
3386     # later simply overriding earlie.  So we need to:
3387     #  - search the command line for these options
3388     #  - pick the last one
3389     #  - perhaps add our own as a default
3390     #  - perhaps adjust it to the corresponding non-source-building version
3391     my $dmode = '-F';
3392     foreach my $l ($cmd, $xargs) {
3393         next unless $l;
3394         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3395     }
3396     push @$cmd, '-nc';
3397 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3398     my $r = 0;
3399     if ($need_split_build_invocation) {
3400         printdebug "massage split $dmode.\n";
3401         $r = $dmode =~ m/[S]/     ? +2 :
3402              $dmode =~ y/gGF/ABb/ ? +1 :
3403              $dmode =~ m/[ABb]/   ?  0 :
3404              die "$dmode ?";
3405     }
3406     printdebug "massage done $r $dmode.\n";
3407     push @$cmd, $dmode;
3408 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3409     return $r;
3410 }
3411
3412 sub cmd_build {
3413     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3414     my $wantsrc = massage_dbp_args \@dbp;
3415     if ($wantsrc > 0) {
3416         build_source();
3417     } else {
3418         build_prep();
3419     }
3420     if ($wantsrc < 2) {
3421         push @dbp, changesopts_version();
3422         maybe_apply_patches_dirtily();
3423         runcmd_ordryrun_local @dbp;
3424     }
3425     maybe_unapply_patches_again();
3426     printdone "build successful\n";
3427 }
3428
3429 sub cmd_gbp_build {
3430     my @dbp = @dpkgbuildpackage;
3431
3432     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3433
3434     my @cmd;
3435     if (length executable_on_path('git-buildpackage')) {
3436         @cmd = qw(git-buildpackage);
3437     } else {
3438         @cmd = qw(gbp buildpackage);
3439     }
3440     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3441
3442     if ($wantsrc > 0) {
3443         build_source();
3444     } else {
3445         if (!$clean_using_builder) {
3446             push @cmd, '--git-cleaner=true';
3447         }
3448         build_prep();
3449     }
3450     if ($wantsrc < 2) {
3451         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3452             canonicalise_suite();
3453             push @cmd, "--git-debian-branch=".lbranch();
3454         }
3455         push @cmd, changesopts();
3456         maybe_apply_patches_dirtily();
3457         runcmd_ordryrun_local @cmd, @ARGV;
3458     }
3459     maybe_unapply_patches_again();
3460     printdone "build successful\n";
3461 }
3462 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3463
3464 sub build_source {
3465     my $our_cleanmode = $cleanmode;
3466     if ($need_split_build_invocation) {
3467         # Pretend that clean is being done some other way.  This
3468         # forces us not to try to use dpkg-buildpackage to clean and
3469         # build source all in one go; and instead we run dpkg-source
3470         # (and build_prep() will do the clean since $clean_using_builder
3471         # is false).
3472         $our_cleanmode = 'ELSEWHERE';
3473     }
3474     if ($our_cleanmode =~ m/^dpkg-source/) {
3475         # dpkg-source invocation (below) will clean, so build_prep shouldn't
3476         $clean_using_builder = 1;
3477     }
3478     build_prep();
3479     $sourcechanges = changespat $version,'source';
3480     if (act_local()) {
3481         unlink "../$sourcechanges" or $!==ENOENT
3482             or fail "remove $sourcechanges: $!";
3483     }
3484     $dscfn = dscfn($version);
3485     if ($our_cleanmode eq 'dpkg-source') {
3486         maybe_apply_patches_dirtily();
3487         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3488             changesopts();
3489     } elsif ($our_cleanmode eq 'dpkg-source-d') {
3490         maybe_apply_patches_dirtily();
3491         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3492             changesopts();
3493     } else {
3494         my @cmd = (@dpkgsource, qw(-b --));
3495         if ($split_brain) {
3496             changedir $ud;
3497             runcmd_ordryrun_local @cmd, "work";
3498             my @udfiles = <${package}_*>;
3499             changedir "../../..";
3500             foreach my $f (@udfiles) {
3501                 printdebug "source copy, found $f\n";
3502                 next unless
3503                     $f eq $dscfn or
3504                     ($f =~ m/\.debian\.tar(?:\.\w+)$/ &&
3505                      $f eq srcfn($version, $&));
3506                 printdebug "source copy, found $f - renaming\n";
3507                 rename "$ud/$f", "../$f" or $!==ENOENT
3508                     or fail "put in place new source file ($f): $!";
3509             }
3510         } else {
3511             my $pwd = must_getcwd();
3512             my $leafdir = basename $pwd;
3513             changedir "..";
3514             runcmd_ordryrun_local @cmd, $leafdir;
3515             changedir $pwd;
3516         }
3517         runcmd_ordryrun_local qw(sh -ec),
3518             'exec >$1; shift; exec "$@"','x',
3519             "../$sourcechanges",
3520             @dpkggenchanges, qw(-S), changesopts();
3521     }
3522 }
3523
3524 sub cmd_build_source {
3525     badusage "build-source takes no additional arguments" if @ARGV;
3526     build_source();
3527     maybe_unapply_patches_again();
3528     printdone "source built, results in $dscfn and $sourcechanges";
3529 }
3530
3531 sub cmd_sbuild {
3532     build_source();
3533     my $pat = changespat $version;
3534     if (!$rmchanges) {
3535         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3536         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3537         fail "changes files other than source matching $pat".
3538             " already present (@unwanted);".
3539             " building would result in ambiguity about the intended results"
3540             if @unwanted;
3541     }
3542     changedir "..";
3543     if (act_local()) {
3544         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3545         stat_exists $sourcechanges
3546             or fail "$sourcechanges (in parent directory): $!";
3547     }
3548     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3549     my @changesfiles = glob $pat;
3550     @changesfiles = sort {
3551         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3552             or $a cmp $b
3553     } @changesfiles;
3554     fail "wrong number of different changes files (@changesfiles)"
3555         unless @changesfiles==2;
3556     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3557     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3558         fail "$l found in binaries changes file $binchanges"
3559             if $l =~ m/\.dsc$/;
3560     }
3561     runcmd_ordryrun_local @mergechanges, @changesfiles;
3562     my $multichanges = changespat $version,'multi';
3563     if (act_local()) {
3564         stat_exists $multichanges or fail "$multichanges: $!";
3565         foreach my $cf (glob $pat) {
3566             next if $cf eq $multichanges;
3567             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3568         }
3569     }
3570     maybe_unapply_patches_again();
3571     printdone "build successful, results in $multichanges\n" or die $!;
3572 }    
3573
3574 sub cmd_quilt_fixup {
3575     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3576     my $clogp = parsechangelog();
3577     $version = getfield $clogp, 'Version';
3578     $package = getfield $clogp, 'Source';
3579     check_not_dirty();
3580     clean_tree();
3581     build_maybe_quilt_fixup();
3582 }
3583
3584 sub cmd_archive_api_query {
3585     badusage "need only 1 subpath argument" unless @ARGV==1;
3586     my ($subpath) = @ARGV;
3587     my @cmd = archive_api_query_cmd($subpath);
3588     debugcmd ">",@cmd;
3589     exec @cmd or fail "exec curl: $!\n";
3590 }
3591
3592 sub cmd_clone_dgit_repos_server {
3593     badusage "need destination argument" unless @ARGV==1;
3594     my ($destdir) = @ARGV;
3595     $package = '_dgit-repos-server';
3596     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3597     debugcmd ">",@cmd;
3598     exec @cmd or fail "exec git clone: $!\n";
3599 }
3600
3601 sub cmd_setup_mergechangelogs {
3602     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3603     setup_mergechangelogs(1);
3604 }
3605
3606 sub cmd_setup_useremail {
3607     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3608     setup_useremail(1);
3609 }
3610
3611 sub cmd_setup_new_tree {
3612     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3613     setup_new_tree();
3614 }
3615
3616 #---------- argument parsing and main program ----------
3617
3618 sub cmd_version {
3619     print "dgit version $our_version\n" or die $!;
3620     exit 0;
3621 }
3622
3623 our (%valopts_long, %valopts_short);
3624 our @rvalopts;
3625
3626 sub defvalopt ($$$$) {
3627     my ($long,$short,$val_re,$how) = @_;
3628     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3629     $valopts_long{$long} = $oi;
3630     $valopts_short{$short} = $oi;
3631     # $how subref should:
3632     #   do whatever assignemnt or thing it likes with $_[0]
3633     #   if the option should not be passed on to remote, @rvalopts=()
3634     # or $how can be a scalar ref, meaning simply assign the value
3635 }
3636
3637 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3638 defvalopt '--distro',        '-d', '.+',      \$idistro;
3639 defvalopt '',                '-k', '.+',      \$keyid;
3640 defvalopt '--existing-package','', '.*',      \$existing_package;
3641 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
3642 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
3643 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
3644
3645 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3646
3647 defvalopt '', '-C', '.+', sub {
3648     ($changesfile) = (@_);
3649     if ($changesfile =~ s#^(.*)/##) {
3650         $buildproductsdir = $1;
3651     }
3652 };
3653
3654 defvalopt '--initiator-tempdir','','.*', sub {
3655     ($initiator_tempdir) = (@_);
3656     $initiator_tempdir =~ m#^/# or
3657         badusage "--initiator-tempdir must be used specify an".
3658         " absolute, not relative, directory."
3659 };
3660
3661 sub parseopts () {
3662     my $om;
3663
3664     if (defined $ENV{'DGIT_SSH'}) {
3665         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3666     } elsif (defined $ENV{'GIT_SSH'}) {
3667         @ssh = ($ENV{'GIT_SSH'});
3668     }
3669
3670     my $oi;
3671     my $val;
3672     my $valopt = sub {
3673         my ($what) = @_;
3674         @rvalopts = ($_);
3675         if (!defined $val) {
3676             badusage "$what needs a value" unless @ARGV;
3677             $val = shift @ARGV;
3678             push @rvalopts, $val;
3679         }
3680         badusage "bad value \`$val' for $what" unless
3681             $val =~ m/^$oi->{Re}$(?!\n)/s;
3682         my $how = $oi->{How};
3683         if (ref($how) eq 'SCALAR') {
3684             $$how = $val;
3685         } else {
3686             $how->($val);
3687         }
3688         push @ropts, @rvalopts;
3689     };
3690
3691     while (@ARGV) {
3692         last unless $ARGV[0] =~ m/^-/;
3693         $_ = shift @ARGV;
3694         last if m/^--?$/;
3695         if (m/^--/) {
3696             if (m/^--dry-run$/) {
3697                 push @ropts, $_;
3698                 $dryrun_level=2;
3699             } elsif (m/^--damp-run$/) {
3700                 push @ropts, $_;
3701                 $dryrun_level=1;
3702             } elsif (m/^--no-sign$/) {
3703                 push @ropts, $_;
3704                 $sign=0;
3705             } elsif (m/^--help$/) {
3706                 cmd_help();
3707             } elsif (m/^--version$/) {
3708                 cmd_version();
3709             } elsif (m/^--new$/) {
3710                 push @ropts, $_;
3711                 $new_package=1;
3712             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3713                      ($om = $opts_opt_map{$1}) &&
3714                      length $om->[0]) {
3715                 push @ropts, $_;
3716                 $om->[0] = $2;
3717             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3718                      !$opts_opt_cmdonly{$1} &&
3719                      ($om = $opts_opt_map{$1})) {
3720                 push @ropts, $_;
3721                 push @$om, $2;
3722             } elsif (m/^--ignore-dirty$/s) {
3723                 push @ropts, $_;
3724                 $ignoredirty = 1;
3725             } elsif (m/^--no-quilt-fixup$/s) {
3726                 push @ropts, $_;
3727                 $quilt_mode = 'nocheck';
3728             } elsif (m/^--no-rm-on-error$/s) {
3729                 push @ropts, $_;
3730                 $rmonerror = 0;
3731             } elsif (m/^--(no-)?rm-old-changes$/s) {
3732                 push @ropts, $_;
3733                 $rmchanges = !$1;
3734             } elsif (m/^--deliberately-($deliberately_re)$/s) {
3735                 push @ropts, $_;
3736                 push @deliberatelies, $&;
3737             } elsif (m/^--always-split-source-build$/s) {
3738                 # undocumented, for testing
3739                 push @ropts, $_;
3740                 $need_split_build_invocation = 1;
3741             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3742                 $val = $2 ? $' : undef; #';
3743                 $valopt->($oi->{Long});
3744             } else {
3745                 badusage "unknown long option \`$_'";
3746             }
3747         } else {
3748             while (m/^-./s) {
3749                 if (s/^-n/-/) {
3750                     push @ropts, $&;
3751                     $dryrun_level=2;
3752                 } elsif (s/^-L/-/) {
3753                     push @ropts, $&;
3754