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