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