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