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