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