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