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