chiark / gitweb /
dgit: Always print canonical suite name
[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 "$us 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     } else {
1566         progress "canonical suite name is $csuite";
1567     }
1568 }
1569
1570 sub get_archive_dsc () {
1571     canonicalise_suite();
1572     my @vsns = archive_query('archive_query');
1573     foreach my $vinfo (@vsns) {
1574         my ($vsn,$vsn_dscurl,$digester,$digest) = @$vinfo;
1575         $dscurl = $vsn_dscurl;
1576         $dscdata = url_get($dscurl);
1577         if (!$dscdata) {
1578             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
1579             next;
1580         }
1581         if ($digester) {
1582             $digester->reset();
1583             $digester->add($dscdata);
1584             my $got = $digester->hexdigest();
1585             $got eq $digest or
1586                 fail "$dscurl has hash $got but".
1587                     " archive told us to expect $digest";
1588         }
1589         parse_dscdata();
1590         my $fmt = getfield $dsc, 'Format';
1591         $format_ok{$fmt} or forceable_fail [qw(unsupported-source-format)],
1592             "unsupported source format $fmt, sorry";
1593             
1594         $dsc_checked = !!$digester;
1595         printdebug "get_archive_dsc: Version ".(getfield $dsc, 'Version')."\n";
1596         return;
1597     }
1598     $dsc = undef;
1599     printdebug "get_archive_dsc: nothing in archive, returning undef\n";
1600 }
1601
1602 sub check_for_git ();
1603 sub check_for_git () {
1604     # returns 0 or 1
1605     my $how = access_cfg('git-check');
1606     if ($how eq 'ssh-cmd') {
1607         my @cmd =
1608             (access_cfg_ssh, access_gituserhost(),
1609              access_runeinfo("git-check $package").
1610              " set -e; cd ".access_cfg('git-path').";".
1611              " if test -d $package.git; then echo 1; else echo 0; fi");
1612         my $r= cmdoutput @cmd;
1613         if (defined $r and $r =~ m/^divert (\w+)$/) {
1614             my $divert=$1;
1615             my ($usedistro,) = access_distros();
1616             # NB that if we are pushing, $usedistro will be $distro/push
1617             $instead_distro= cfg("dgit-distro.$usedistro.diverts.$divert");
1618             $instead_distro =~ s{^/}{ access_basedistro()."/" }e;
1619             progress "diverting to $divert (using config for $instead_distro)";
1620             return check_for_git();
1621         }
1622         failedcmd @cmd unless defined $r and $r =~ m/^[01]$/;
1623         return $r+0;
1624     } elsif ($how eq 'url') {
1625         my $prefix = access_cfg('git-check-url','git-url');
1626         my $suffix = access_cfg('git-check-suffix','git-suffix',
1627                                 'RETURN-UNDEF') // '.git';
1628         my $url = "$prefix/$package$suffix";
1629         my @cmd = (@curl, qw(-sS -I), $url);
1630         my $result = cmdoutput @cmd;
1631         $result =~ s/^\S+ 200 .*\n\r?\n//;
1632         # curl -sS -I with https_proxy prints
1633         # HTTP/1.0 200 Connection established
1634         $result =~ m/^\S+ (404|200) /s or
1635             fail "unexpected results from git check query - ".
1636                 Dumper($prefix, $result);
1637         my $code = $1;
1638         if ($code eq '404') {
1639             return 0;
1640         } elsif ($code eq '200') {
1641             return 1;
1642         } else {
1643             die;
1644         }
1645     } elsif ($how eq 'true') {
1646         return 1;
1647     } elsif ($how eq 'false') {
1648         return 0;
1649     } else {
1650         badcfg "unknown git-check \`$how'";
1651     }
1652 }
1653
1654 sub create_remote_git_repo () {
1655     my $how = access_cfg('git-create');
1656     if ($how eq 'ssh-cmd') {
1657         runcmd_ordryrun
1658             (access_cfg_ssh, access_gituserhost(),
1659              access_runeinfo("git-create $package").
1660              "set -e; cd ".access_cfg('git-path').";".
1661              " cp -a _template $package.git");
1662     } elsif ($how eq 'true') {
1663         # nothing to do
1664     } else {
1665         badcfg "unknown git-create \`$how'";
1666     }
1667 }
1668
1669 our ($dsc_hash,$lastpush_mergeinput);
1670
1671 our $ud = '.git/dgit/unpack';
1672
1673 sub prep_ud (;$) {
1674     my ($d) = @_;
1675     $d //= $ud;
1676     rmtree($d);
1677     mkpath '.git/dgit';
1678     mkdir $d or die $!;
1679 }
1680
1681 sub mktree_in_ud_here () {
1682     runcmd qw(git init -q);
1683     runcmd qw(git config gc.auto 0);
1684     rmtree('.git/objects');
1685     symlink '../../../../objects','.git/objects' or die $!;
1686 }
1687
1688 sub git_write_tree () {
1689     my $tree = cmdoutput @git, qw(write-tree);
1690     $tree =~ m/^\w+$/ or die "$tree ?";
1691     return $tree;
1692 }
1693
1694 sub remove_stray_gits () {
1695     my @gitscmd = qw(find -name .git -prune -print0);
1696     debugcmd "|",@gitscmd;
1697     open GITS, "-|", @gitscmd or die $!;
1698     {
1699         local $/="\0";
1700         while (<GITS>) {
1701             chomp or die;
1702             print STDERR "$us: warning: removing from source package: ",
1703                 (messagequote $_), "\n";
1704             rmtree $_;
1705         }
1706     }
1707     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1708 }
1709
1710 sub mktree_in_ud_from_only_subdir (;$) {
1711     my ($raw) = @_;
1712
1713     # changes into the subdir
1714     my (@dirs) = <*/.>;
1715     die "expected one subdir but found @dirs ?" unless @dirs==1;
1716     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1717     my $dir = $1;
1718     changedir $dir;
1719
1720     remove_stray_gits();
1721     mktree_in_ud_here();
1722     if (!$raw) {
1723         my ($format, $fopts) = get_source_format();
1724         if (madformat($format)) {
1725             rmtree '.pc';
1726         }
1727     }
1728
1729     runcmd @git, qw(add -Af);
1730     my $tree=git_write_tree();
1731     return ($tree,$dir);
1732 }
1733
1734 our @files_csum_info_fields = 
1735     (['Checksums-Sha256','Digest::SHA', 'new(256)', 'sha256sum'],
1736      ['Checksums-Sha1',  'Digest::SHA', 'new(1)',   'sha1sum'],
1737      ['Files',           'Digest::MD5', 'new()',    'md5sum']);
1738
1739 sub dsc_files_info () {
1740     foreach my $csumi (@files_csum_info_fields) {
1741         my ($fname, $module, $method) = @$csumi;
1742         my $field = $dsc->{$fname};
1743         next unless defined $field;
1744         eval "use $module; 1;" or die $@;
1745         my @out;
1746         foreach (split /\n/, $field) {
1747             next unless m/\S/;
1748             m/^(\w+) (\d+) (\S+)$/ or
1749                 fail "could not parse .dsc $fname line \`$_'";
1750             my $digester = eval "$module"."->$method;" or die $@;
1751             push @out, {
1752                 Hash => $1,
1753                 Bytes => $2,
1754                 Filename => $3,
1755                 Digester => $digester,
1756             };
1757         }
1758         return @out;
1759     }
1760     fail "missing any supported Checksums-* or Files field in ".
1761         $dsc->get_option('name');
1762 }
1763
1764 sub dsc_files () {
1765     map { $_->{Filename} } dsc_files_info();
1766 }
1767
1768 sub files_compare_inputs (@) {
1769     my $inputs = \@_;
1770     my %record;
1771     my %fchecked;
1772
1773     my $showinputs = sub {
1774         return join "; ", map { $_->get_option('name') } @$inputs;
1775     };
1776
1777     foreach my $in (@$inputs) {
1778         my $expected_files;
1779         my $in_name = $in->get_option('name');
1780
1781         printdebug "files_compare_inputs $in_name\n";
1782
1783         foreach my $csumi (@files_csum_info_fields) {
1784             my ($fname) = @$csumi;
1785             printdebug "files_compare_inputs $in_name $fname\n";
1786
1787             my $field = $in->{$fname};
1788             next unless defined $field;
1789
1790             my @files;
1791             foreach (split /\n/, $field) {
1792                 next unless m/\S/;
1793
1794                 my ($info, $f) = m/^(\w+ \d+) (?:\S+ \S+ )?(\S+)$/ or
1795                     fail "could not parse $in_name $fname line \`$_'";
1796
1797                 printdebug "files_compare_inputs $in_name $fname $f\n";
1798
1799                 push @files, $f;
1800
1801                 my $re = \ $record{$f}{$fname};
1802                 if (defined $$re) {
1803                     $fchecked{$f}{$in_name} = 1;
1804                     $$re eq $info or
1805                         fail "hash or size of $f varies in $fname fields".
1806                         " (between: ".$showinputs->().")";
1807                 } else {
1808                     $$re = $info;
1809                 }
1810             }
1811             @files = sort @files;
1812             $expected_files //= \@files;
1813             "@$expected_files" eq "@files" or
1814                 fail "file list in $in_name varies between hash fields!";
1815         }
1816         $expected_files or
1817             fail "$in_name has no files list field(s)";
1818     }
1819     printdebug "files_compare_inputs ".Dumper(\%fchecked, \%record)
1820         if $debuglevel>=2;
1821
1822     grep { keys %$_ == @$inputs-1 } values %fchecked
1823         or fail "no file appears in all file lists".
1824         " (looked in: ".$showinputs->().")";
1825 }
1826
1827 sub is_orig_file_in_dsc ($$) {
1828     my ($f, $dsc_files_info) = @_;
1829     return 0 if @$dsc_files_info <= 1;
1830     # One file means no origs, and the filename doesn't have a "what
1831     # part of dsc" component.  (Consider versions ending `.orig'.)
1832     return 0 unless $f =~ m/\.$orig_f_tail_re$/o;
1833     return 1;
1834 }
1835
1836 sub is_orig_file_of_vsn ($$) {
1837     my ($f, $upstreamvsn) = @_;
1838     my $base = srcfn $upstreamvsn, '';
1839     return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
1840     return 1;
1841 }
1842
1843 sub changes_update_origs_from_dsc ($$$$) {
1844     my ($dsc, $changes, $upstreamvsn, $changesfile) = @_;
1845     my %changes_f;
1846     printdebug "checking origs needed ($upstreamvsn)...\n";
1847     $_ = getfield $changes, 'Files';
1848     m/^\w+ \d+ (\S+ \S+) \S+$/m or
1849         fail "cannot find section/priority from .changes Files field";
1850     my $placementinfo = $1;
1851     my %changed;
1852     printdebug "checking origs needed placement '$placementinfo'...\n";
1853     foreach my $l (split /\n/, getfield $dsc, 'Files') {
1854         $l =~ m/\S+$/ or next;
1855         my $file = $&;
1856         printdebug "origs $file | $l\n";
1857         next unless is_orig_file_of_vsn $file, $upstreamvsn;
1858         printdebug "origs $file is_orig\n";
1859         my $have = archive_query('file_in_archive', $file);
1860         if (!defined $have) {
1861             print STDERR <<END;
1862 archive does not support .orig check; hope you used --ch:--sa/-sd if needed
1863 END
1864             return;
1865         }
1866         my $found_same = 0;
1867         my @found_differ;
1868         printdebug "origs $file \$#\$have=$#$have\n";
1869         foreach my $h (@$have) {
1870             my $same = 0;
1871             my @differ;
1872             foreach my $csumi (@files_csum_info_fields) {
1873                 my ($fname, $module, $method, $archivefield) = @$csumi;
1874                 next unless defined $h->{$archivefield};
1875                 $_ = $dsc->{$fname};
1876                 next unless defined;
1877                 m/^(\w+) .* \Q$file\E$/m or
1878                     fail ".dsc $fname missing entry for $file";
1879                 if ($h->{$archivefield} eq $1) {
1880                     $same++;
1881                 } else {
1882                     push @differ,
1883  "$archivefield: $h->{$archivefield} (archive) != $1 (local .dsc)";
1884                 }
1885             }
1886             die "$file ".Dumper($h)." ?!" if $same && @differ;
1887             $found_same++
1888                 if $same;
1889             push @found_differ, "archive $h->{filename}: ".join "; ", @differ
1890                 if @differ;
1891         }
1892         print "origs $file f.same=$found_same #f._differ=$#found_differ\n";
1893         if (@found_differ && !$found_same) {
1894             fail join "\n",
1895                 "archive contains $file with different checksum",
1896                 @found_differ;
1897         }
1898         # Now we edit the changes file to add or remove it
1899         foreach my $csumi (@files_csum_info_fields) {
1900             my ($fname, $module, $method, $archivefield) = @$csumi;
1901             next unless defined $changes->{$fname};
1902             if ($found_same) {
1903                 # in archive, delete from .changes if it's there
1904                 $changed{$file} = "removed" if
1905                     $changes->{$fname} =~ s/^.* \Q$file\E$(?:)\n//m;
1906             } elsif ($changes->{$fname} =~ m/^.* \Q$file\E$(?:)\n/m) {
1907                 # not in archive, but it's here in the .changes
1908             } else {
1909                 my $dsc_data = getfield $dsc, $fname;
1910                 $dsc_data =~ m/^(.* \Q$file\E$)\n/m or die "$dsc_data $file ?";
1911                 my $extra = $1;
1912                 $extra =~ s/ \d+ /$&$placementinfo /
1913                     or die "$fname $extra >$dsc_data< ?"
1914                     if $fname eq 'Files';
1915                 $changes->{$fname} .= "\n". $extra;
1916                 $changed{$file} = "added";
1917             }
1918         }
1919     }
1920     if (%changed) {
1921         foreach my $file (keys %changed) {
1922             progress sprintf
1923                 "edited .changes for archive .orig contents: %s %s",
1924                 $changed{$file}, $file;
1925         }
1926         my $chtmp = "$changesfile.tmp";
1927         $changes->save($chtmp);
1928         if (act_local()) {
1929             rename $chtmp,$changesfile or die "$changesfile $!";
1930         } else {
1931             progress "[new .changes left in $changesfile]";
1932         }
1933     } else {
1934         progress "$changesfile already has appropriate .orig(s) (if any)";
1935     }
1936 }
1937
1938 sub make_commit ($) {
1939     my ($file) = @_;
1940     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1941 }
1942
1943 sub make_commit_text ($) {
1944     my ($text) = @_;
1945     my ($out, $in);
1946     my @cmd = (@git, qw(hash-object -w -t commit --stdin));
1947     debugcmd "|",@cmd;
1948     print Dumper($text) if $debuglevel > 1;
1949     my $child = open2($out, $in, @cmd) or die $!;
1950     my $h;
1951     eval {
1952         print $in $text or die $!;
1953         close $in or die $!;
1954         $h = <$out>;
1955         $h =~ m/^\w+$/ or die;
1956         $h = $&;
1957         printdebug "=> $h\n";
1958     };
1959     close $out;
1960     waitpid $child, 0 == $child or die "$child $!";
1961     $? and failedcmd @cmd;
1962     return $h;
1963 }
1964
1965 sub clogp_authline ($) {
1966     my ($clogp) = @_;
1967     my $author = getfield $clogp, 'Maintainer';
1968     $author =~ s#,.*##ms;
1969     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1970     my $authline = "$author $date";
1971     $authline =~ m/$git_authline_re/o or
1972         fail "unexpected commit author line format \`$authline'".
1973         " (was generated from changelog Maintainer field)";
1974     return ($1,$2,$3) if wantarray;
1975     return $authline;
1976 }
1977
1978 sub vendor_patches_distro ($$) {
1979     my ($checkdistro, $what) = @_;
1980     return unless defined $checkdistro;
1981
1982     my $series = "debian/patches/\L$checkdistro\E.series";
1983     printdebug "checking for vendor-specific $series ($what)\n";
1984
1985     if (!open SERIES, "<", $series) {
1986         die "$series $!" unless $!==ENOENT;
1987         return;
1988     }
1989     while (<SERIES>) {
1990         next unless m/\S/;
1991         next if m/^\s+\#/;
1992
1993         print STDERR <<END;
1994
1995 Unfortunately, this source package uses a feature of dpkg-source where
1996 the same source package unpacks to different source code on different
1997 distros.  dgit cannot safely operate on such packages on affected
1998 distros, because the meaning of source packages is not stable.
1999
2000 Please ask the distro/maintainer to remove the distro-specific series
2001 files and use a different technique (if necessary, uploading actually
2002 different packages, if different distros are supposed to have
2003 different code).
2004
2005 END
2006         fail "Found active distro-specific series file for".
2007             " $checkdistro ($what): $series, cannot continue";
2008     }
2009     die "$series $!" if SERIES->error;
2010     close SERIES;
2011 }
2012
2013 sub check_for_vendor_patches () {
2014     # This dpkg-source feature doesn't seem to be documented anywhere!
2015     # But it can be found in the changelog (reformatted):
2016
2017     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
2018     #   Author: Raphael Hertzog <hertzog@debian.org>
2019     #   Date: Sun  Oct  3  09:36:48  2010 +0200
2020
2021     #   dpkg-source: correctly create .pc/.quilt_series with alternate
2022     #   series files
2023     #   
2024     #   If you have debian/patches/ubuntu.series and you were
2025     #   unpacking the source package on ubuntu, quilt was still
2026     #   directed to debian/patches/series instead of
2027     #   debian/patches/ubuntu.series.
2028     #   
2029     #   debian/changelog                        |    3 +++
2030     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
2031     #   2 files changed, 6 insertions(+), 1 deletion(-)
2032
2033     use Dpkg::Vendor;
2034     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
2035     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
2036                          "Dpkg::Vendor \`current vendor'");
2037     vendor_patches_distro(access_basedistro(),
2038                           "(base) distro being accessed");
2039     vendor_patches_distro(access_nomdistro(),
2040                           "(nominal) distro being accessed");
2041 }
2042
2043 sub generate_commits_from_dsc () {
2044     # See big comment in fetch_from_archive, below.
2045     # See also README.dsc-import.
2046     prep_ud();
2047     changedir $ud;
2048
2049     my @dfi = dsc_files_info();
2050     foreach my $fi (@dfi) {
2051         my $f = $fi->{Filename};
2052         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
2053
2054         printdebug "considering linking $f: ";
2055
2056         link_ltarget "../../../../$f", $f
2057             or ((printdebug "($!) "), 0)
2058             or $!==&ENOENT
2059             or die "$f $!";
2060
2061         printdebug "linked.\n";
2062
2063         complete_file_from_dsc('.', $fi)
2064             or next;
2065
2066         if (is_orig_file_in_dsc($f, \@dfi)) {
2067             link $f, "../../../../$f"
2068                 or $!==&EEXIST
2069                 or die "$f $!";
2070         }
2071     }
2072
2073     # We unpack and record the orig tarballs first, so that we only
2074     # need disk space for one private copy of the unpacked source.
2075     # But we can't make them into commits until we have the metadata
2076     # from the debian/changelog, so we record the tree objects now and
2077     # make them into commits later.
2078     my @tartrees;
2079     my $upstreamv = upstreamversion $dsc->{version};
2080     my $orig_f_base = srcfn $upstreamv, '';
2081
2082     foreach my $fi (@dfi) {
2083         # We actually import, and record as a commit, every tarball
2084         # (unless there is only one file, in which case there seems
2085         # little point.
2086
2087         my $f = $fi->{Filename};
2088         printdebug "import considering $f ";
2089         (printdebug "only one dfi\n"), next if @dfi == 1;
2090         (printdebug "not tar\n"), next unless $f =~ m/\.tar(\.\w+)?$/;
2091         (printdebug "signature\n"), next if $f =~ m/$orig_f_sig_re$/o;
2092         my $compr_ext = $1;
2093
2094         my ($orig_f_part) =
2095             $f =~ m/^\Q$orig_f_base\E\.([^._]+)?\.tar(?:\.\w+)?$/;
2096
2097         printdebug "Y ", (join ' ', map { $_//"(none)" }
2098                           $compr_ext, $orig_f_part
2099                          ), "\n";
2100
2101         my $input = new IO::File $f, '<' or die "$f $!";
2102         my $compr_pid;
2103         my @compr_cmd;
2104
2105         if (defined $compr_ext) {
2106             my $cname =
2107                 Dpkg::Compression::compression_guess_from_filename $f;
2108             fail "Dpkg::Compression cannot handle file $f in source package"
2109                 if defined $compr_ext && !defined $cname;
2110             my $compr_proc =
2111                 new Dpkg::Compression::Process compression => $cname;
2112             my @compr_cmd = $compr_proc->get_uncompress_cmdline();
2113             my $compr_fh = new IO::Handle;
2114             my $compr_pid = open $compr_fh, "-|" // die $!;
2115             if (!$compr_pid) {
2116                 open STDIN, "<&", $input or die $!;
2117                 exec @compr_cmd;
2118                 die "dgit (child): exec $compr_cmd[0]: $!\n";
2119             }
2120             $input = $compr_fh;
2121         }
2122
2123         rmtree "../unpack-tar";
2124         mkdir "../unpack-tar" or die $!;
2125         my @tarcmd = qw(tar -x -f -
2126                         --no-same-owner --no-same-permissions
2127                         --no-acls --no-xattrs --no-selinux);
2128         my $tar_pid = fork // die $!;
2129         if (!$tar_pid) {
2130             chdir "../unpack-tar" or die $!;
2131             open STDIN, "<&", $input or die $!;
2132             exec @tarcmd;
2133             die "dgit (child): exec $tarcmd[0]: $!";
2134         }
2135         $!=0; (waitpid $tar_pid, 0) == $tar_pid or die $!;
2136         !$? or failedcmd @tarcmd;
2137
2138         close $input or
2139             (@compr_cmd ? failedcmd @compr_cmd
2140              : die $!);
2141         # finally, we have the results in "tarball", but maybe
2142         # with the wrong permissions
2143
2144         runcmd qw(chmod -R +rwX ../unpack-tar);
2145         changedir "../unpack-tar";
2146         my ($tree) = mktree_in_ud_from_only_subdir(1);
2147         changedir "../../unpack";
2148         rmtree "../unpack-tar";
2149
2150         my $ent = [ $f, $tree ];
2151         push @tartrees, {
2152             Orig => !!$orig_f_part,
2153             Sort => (!$orig_f_part         ? 2 :
2154                      $orig_f_part =~ m/-/g ? 1 :
2155                                              0),
2156             F => $f,
2157             Tree => $tree,
2158         };
2159     }
2160
2161     @tartrees = sort {
2162         # put any without "_" first (spec is not clear whether files
2163         # are always in the usual order).  Tarballs without "_" are
2164         # the main orig or the debian tarball.
2165         $a->{Sort} <=> $b->{Sort} or
2166         $a->{F}    cmp $b->{F}
2167     } @tartrees;
2168
2169     my $any_orig = grep { $_->{Orig} } @tartrees;
2170
2171     my $dscfn = "$package.dsc";
2172
2173     my $treeimporthow = 'package';
2174
2175     open D, ">", $dscfn or die "$dscfn: $!";
2176     print D $dscdata or die "$dscfn: $!";
2177     close D or die "$dscfn: $!";
2178     my @cmd = qw(dpkg-source);
2179     push @cmd, '--no-check' if $dsc_checked;
2180     if (madformat $dsc->{format}) {
2181         push @cmd, '--skip-patches';
2182         $treeimporthow = 'unpatched';
2183     }
2184     push @cmd, qw(-x --), $dscfn;
2185     runcmd @cmd;
2186
2187     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
2188     if (madformat $dsc->{format}) { 
2189         check_for_vendor_patches();
2190     }
2191
2192     my $dappliedtree;
2193     if (madformat $dsc->{format}) {
2194         my @pcmd = qw(dpkg-source --before-build .);
2195         runcmd shell_cmd 'exec >/dev/null', @pcmd;
2196         rmtree '.pc';
2197         runcmd @git, qw(add -Af);
2198         $dappliedtree = git_write_tree();
2199     }
2200
2201     my @clogcmd = qw(dpkg-parsechangelog --format rfc822 --all);
2202     debugcmd "|",@clogcmd;
2203     open CLOGS, "-|", @clogcmd or die $!;
2204
2205     my $clogp;
2206     my $r1clogp;
2207
2208     printdebug "import clog search...\n";
2209
2210     for (;;) {
2211         my $stanzatext = do { local $/=""; <CLOGS>; };
2212         printdebug "import clogp ".Dumper($stanzatext) if $debuglevel>1;
2213         last if !defined $stanzatext;
2214
2215         my $desc = "package changelog, entry no.$.";
2216         open my $stanzafh, "<", \$stanzatext or die;
2217         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
2218         $clogp //= $thisstanza;
2219
2220         printdebug "import clog $thisstanza->{version} $desc...\n";
2221
2222         last if !$any_orig; # we don't need $r1clogp
2223
2224         # We look for the first (most recent) changelog entry whose
2225         # version number is lower than the upstream version of this
2226         # package.  Then the last (least recent) previous changelog
2227         # entry is treated as the one which introduced this upstream
2228         # version and used for the synthetic commits for the upstream
2229         # tarballs.
2230
2231         # One might think that a more sophisticated algorithm would be
2232         # necessary.  But: we do not want to scan the whole changelog
2233         # file.  Stopping when we see an earlier version, which
2234         # necessarily then is an earlier upstream version, is the only
2235         # realistic way to do that.  Then, either the earliest
2236         # changelog entry we have seen so far is indeed the earliest
2237         # upload of this upstream version; or there are only changelog
2238         # entries relating to later upstream versions (which is not
2239         # possible unless the changelog and .dsc disagree about the
2240         # version).  Then it remains to choose between the physically
2241         # last entry in the file, and the one with the lowest version
2242         # number.  If these are not the same, we guess that the
2243         # versions were created in a non-monotic order rather than
2244         # that the changelog entries have been misordered.
2245
2246         printdebug "import clog $thisstanza->{version} vs $upstreamv...\n";
2247
2248         last if version_compare($thisstanza->{version}, $upstreamv) < 0;
2249         $r1clogp = $thisstanza;
2250
2251         printdebug "import clog $r1clogp->{version} becomes r1\n";
2252     }
2253     die $! if CLOGS->error;
2254     close CLOGS or $?==SIGPIPE or failedcmd @clogcmd;
2255
2256     $clogp or fail "package changelog has no entries!";
2257
2258     my $authline = clogp_authline $clogp;
2259     my $changes = getfield $clogp, 'Changes';
2260     my $cversion = getfield $clogp, 'Version';
2261
2262     if (@tartrees) {
2263         $r1clogp //= $clogp; # maybe there's only one entry;
2264         my $r1authline = clogp_authline $r1clogp;
2265         # Strictly, r1authline might now be wrong if it's going to be
2266         # unused because !$any_orig.  Whatever.
2267
2268         printdebug "import tartrees authline   $authline\n";
2269         printdebug "import tartrees r1authline $r1authline\n";
2270
2271         foreach my $tt (@tartrees) {
2272             printdebug "import tartree $tt->{F} $tt->{Tree}\n";
2273
2274             $tt->{Commit} = make_commit_text($tt->{Orig} ? <<END_O : <<END_T);
2275 tree $tt->{Tree}
2276 author $r1authline
2277 committer $r1authline
2278
2279 Import $tt->{F}
2280
2281 [dgit import orig $tt->{F}]
2282 END_O
2283 tree $tt->{Tree}
2284 author $authline
2285 committer $authline
2286
2287 Import $tt->{F}
2288
2289 [dgit import tarball $package $cversion $tt->{F}]
2290 END_T
2291         }
2292     }
2293
2294     printdebug "import main commit\n";
2295
2296     open C, ">../commit.tmp" or die $!;
2297     print C <<END or die $!;
2298 tree $tree
2299 END
2300     print C <<END or die $! foreach @tartrees;
2301 parent $_->{Commit}
2302 END
2303     print C <<END or die $!;
2304 author $authline
2305 committer $authline
2306
2307 $changes
2308
2309 [dgit import $treeimporthow $package $cversion]
2310 END
2311
2312     close C or die $!;
2313     my $rawimport_hash = make_commit qw(../commit.tmp);
2314
2315     if (madformat $dsc->{format}) {
2316         printdebug "import apply patches...\n";
2317
2318         # regularise the state of the working tree so that
2319         # the checkout of $rawimport_hash works nicely.
2320         my $dappliedcommit = make_commit_text(<<END);
2321 tree $dappliedtree
2322 author $authline
2323 committer $authline
2324
2325 [dgit dummy commit]
2326 END
2327         runcmd @git, qw(checkout -q -b dapplied), $dappliedcommit;
2328
2329         runcmd @git, qw(checkout -q -b unpa), $rawimport_hash;
2330
2331         # We need the answers to be reproducible
2332         my @authline = clogp_authline($clogp);
2333         local $ENV{GIT_COMMITTER_NAME} =  $authline[0];
2334         local $ENV{GIT_COMMITTER_EMAIL} = $authline[1];
2335         local $ENV{GIT_COMMITTER_DATE} =  $authline[2];
2336         local $ENV{GIT_AUTHOR_NAME} =  $authline[0];
2337         local $ENV{GIT_AUTHOR_EMAIL} = $authline[1];
2338         local $ENV{GIT_AUTHOR_DATE} =  $authline[2];
2339
2340         my $path = $ENV{PATH} or die;
2341
2342         foreach my $use_absurd (qw(0 1)) {
2343             local $ENV{PATH} = $path;
2344             if ($use_absurd) {
2345                 chomp $@;
2346                 progress "warning: $@";
2347                 $path = "$absurdity:$path";
2348                 progress "$us: trying slow absurd-git-apply...";
2349                 rename "../../gbp-pq-output","../../gbp-pq-output.0"
2350                     or $!==ENOENT
2351                     or die $!;
2352             }
2353             eval {
2354                 die "forbid absurd git-apply\n" if $use_absurd
2355                     && forceing [qw(import-gitapply-no-absurd)];
2356                 die "only absurd git-apply!\n" if !$use_absurd
2357                     && forceing [qw(import-gitapply-absurd)];
2358
2359                 local $ENV{PATH} = $path if $use_absurd;
2360
2361                 my @showcmd = (gbp_pq, qw(import));
2362                 my @realcmd = shell_cmd
2363                     'exec >/dev/null 2>../../gbp-pq-output', @showcmd;
2364                 debugcmd "+",@realcmd;
2365                 if (system @realcmd) {
2366                     die +(shellquote @showcmd).
2367                         " failed: ".
2368                         failedcmd_waitstatus()."\n";
2369                 }
2370
2371                 my $gapplied = git_rev_parse('HEAD');
2372                 my $gappliedtree = cmdoutput @git, qw(rev-parse HEAD:);
2373                 $gappliedtree eq $dappliedtree or
2374                     fail <<END;
2375 gbp-pq import and dpkg-source disagree!
2376  gbp-pq import gave commit $gapplied
2377  gbp-pq import gave tree $gappliedtree
2378  dpkg-source --before-build gave tree $dappliedtree
2379 END
2380                 $rawimport_hash = $gapplied;
2381             };
2382             last unless $@;
2383         }
2384         if ($@) {
2385             { local $@; eval { runcmd qw(cat ../../gbp-pq-output); }; }
2386             die $@;
2387         }
2388     }
2389
2390     progress "synthesised git commit from .dsc $cversion";
2391
2392     my $rawimport_mergeinput = {
2393         Commit => $rawimport_hash,
2394         Info => "Import of source package",
2395     };
2396     my @output = ($rawimport_mergeinput);
2397
2398     if ($lastpush_mergeinput) {
2399         my $oldclogp = mergeinfo_getclogp($lastpush_mergeinput);
2400         my $oversion = getfield $oldclogp, 'Version';
2401         my $vcmp =
2402             version_compare($oversion, $cversion);
2403         if ($vcmp < 0) {
2404             @output = ($rawimport_mergeinput, $lastpush_mergeinput,
2405                 { Message => <<END, ReverseParents => 1 });
2406 Record $package ($cversion) in archive suite $csuite
2407 END
2408         } elsif ($vcmp > 0) {
2409             print STDERR <<END or die $!;
2410
2411 Version actually in archive:   $cversion (older)
2412 Last version pushed with dgit: $oversion (newer or same)
2413 $later_warning_msg
2414 END
2415             @output = $lastpush_mergeinput;
2416         } else {
2417             # Same version.  Use what's in the server git branch,
2418             # discarding our own import.  (This could happen if the
2419             # server automatically imports all packages into git.)
2420             @output = $lastpush_mergeinput;
2421         }
2422     }
2423     changedir '../../../..';
2424     rmtree($ud);
2425     return @output;
2426 }
2427
2428 sub complete_file_from_dsc ($$) {
2429     our ($dstdir, $fi) = @_;
2430     # Ensures that we have, in $dir, the file $fi, with the correct
2431     # contents.  (Downloading it from alongside $dscurl if necessary.)
2432
2433     my $f = $fi->{Filename};
2434     my $tf = "$dstdir/$f";
2435     my $downloaded = 0;
2436
2437     if (stat_exists $tf) {
2438         progress "using existing $f";
2439     } else {
2440         printdebug "$tf does not exist, need to fetch\n";
2441         my $furl = $dscurl;
2442         $furl =~ s{/[^/]+$}{};
2443         $furl .= "/$f";
2444         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
2445         die "$f ?" if $f =~ m#/#;
2446         runcmd_ordryrun_local @curl,qw(-f -o),$tf,'--',"$furl";
2447         return 0 if !act_local();
2448         $downloaded = 1;
2449     }
2450
2451     open F, "<", "$tf" or die "$tf: $!";
2452     $fi->{Digester}->reset();
2453     $fi->{Digester}->addfile(*F);
2454     F->error and die $!;
2455     my $got = $fi->{Digester}->hexdigest();
2456     $got eq $fi->{Hash} or
2457         fail "file $f has hash $got but .dsc".
2458             " demands hash $fi->{Hash} ".
2459             ($downloaded ? "(got wrong file from archive!)"
2460              : "(perhaps you should delete this file?)");
2461
2462     return 1;
2463 }
2464
2465 sub ensure_we_have_orig () {
2466     my @dfi = dsc_files_info();
2467     foreach my $fi (@dfi) {
2468         my $f = $fi->{Filename};
2469         next unless is_orig_file_in_dsc($f, \@dfi);
2470         complete_file_from_dsc('..', $fi)
2471             or next;
2472     }
2473 }
2474
2475 sub git_fetch_us () {
2476     # Want to fetch only what we are going to use, unless
2477     # deliberately-not-ff, in which case we must fetch everything.
2478
2479     my @specs = deliberately_not_fast_forward ? qw(tags/*) :
2480         map { "tags/$_" }
2481         (quiltmode_splitbrain
2482          ? (map { $_->('*',access_nomdistro) }
2483             \&debiantag_new, \&debiantag_maintview)
2484          : debiantags('*',access_nomdistro));
2485     push @specs, server_branch($csuite);
2486     push @specs, qw(heads/*) if deliberately_not_fast_forward;
2487
2488     # This is rather miserable:
2489     # When git fetch --prune is passed a fetchspec ending with a *,
2490     # it does a plausible thing.  If there is no * then:
2491     # - it matches subpaths too, even if the supplied refspec
2492     #   starts refs, and behaves completely madly if the source
2493     #   has refs/refs/something.  (See, for example, Debian #NNNN.)
2494     # - if there is no matching remote ref, it bombs out the whole
2495     #   fetch.
2496     # We want to fetch a fixed ref, and we don't know in advance
2497     # if it exists, so this is not suitable.
2498     #
2499     # Our workaround is to use git ls-remote.  git ls-remote has its
2500     # own qairks.  Notably, it has the absurd multi-tail-matching
2501     # behaviour: git ls-remote R refs/foo can report refs/foo AND
2502     # refs/refs/foo etc.
2503     #
2504     # Also, we want an idempotent snapshot, but we have to make two
2505     # calls to the remote: one to git ls-remote and to git fetch.  The
2506     # solution is use git ls-remote to obtain a target state, and
2507     # git fetch to try to generate it.  If we don't manage to generate
2508     # the target state, we try again.
2509
2510     printdebug "git_fetch_us specs @specs\n";
2511
2512     my $specre = join '|', map {
2513         my $x = $_;
2514         $x =~ s/\W/\\$&/g;
2515         $x =~ s/\\\*$/.*/;
2516         "(?:refs/$x)";
2517     } @specs;
2518     printdebug "git_fetch_us specre=$specre\n";
2519     my $wanted_rref = sub {
2520         local ($_) = @_;
2521         return m/^(?:$specre)$/o;
2522     };
2523
2524     my $fetch_iteration = 0;
2525     FETCH_ITERATION:
2526     for (;;) {
2527         printdebug "git_fetch_us iteration $fetch_iteration\n";
2528         if (++$fetch_iteration > 10) {
2529             fail "too many iterations trying to get sane fetch!";
2530         }
2531
2532         my @look = map { "refs/$_" } @specs;
2533         my @lcmd = (@git, qw(ls-remote -q --refs), access_giturl(), @look);
2534         debugcmd "|",@lcmd;
2535
2536         my %wantr;
2537         open GITLS, "-|", @lcmd or die $!;
2538         while (<GITLS>) {
2539             printdebug "=> ", $_;
2540             m/^(\w+)\s+(\S+)\n/ or die "ls-remote $_ ?";
2541             my ($objid,$rrefname) = ($1,$2);
2542             if (!$wanted_rref->($rrefname)) {
2543                 print STDERR <<END;
2544 warning: git ls-remote @look reported $rrefname; this is silly, ignoring it.
2545 END
2546                 next;
2547             }
2548             $wantr{$rrefname} = $objid;
2549         }
2550         $!=0; $?=0;
2551         close GITLS or failedcmd @lcmd;
2552
2553         # OK, now %want is exactly what we want for refs in @specs
2554         my @fspecs = map {
2555             !m/\*$/ && !exists $wantr{"refs/$_"} ? () :
2556             "+refs/$_:".lrfetchrefs."/$_";
2557         } @specs;
2558
2559         printdebug "git_fetch_us fspecs @fspecs\n";
2560
2561         my @fcmd = (@git, qw(fetch -p -n -q), access_giturl(), @fspecs);
2562         runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(),
2563             @fspecs;
2564
2565         %lrfetchrefs_f = ();
2566         my %objgot;
2567
2568         git_for_each_ref(lrfetchrefs, sub {
2569             my ($objid,$objtype,$lrefname,$reftail) = @_;
2570             $lrfetchrefs_f{$lrefname} = $objid;
2571             $objgot{$objid} = 1;
2572         });
2573
2574         foreach my $lrefname (sort keys %lrfetchrefs_f) {
2575             my $rrefname = 'refs'.substr($lrefname, length lrfetchrefs);
2576             if (!exists $wantr{$rrefname}) {
2577                 if ($wanted_rref->($rrefname)) {
2578                     printdebug <<END;
2579 git-fetch @fspecs created $lrefname which git ls-remote @look didn't list.
2580 END
2581                 } else {
2582                     print STDERR <<END
2583 warning: git fetch @fspecs created $lrefname; this is silly, deleting it.
2584 END
2585                 }
2586                 runcmd_ordryrun_local @git, qw(update-ref -d), $lrefname;
2587                 delete $lrfetchrefs_f{$lrefname};
2588                 next;
2589             }
2590         }
2591         foreach my $rrefname (sort keys %wantr) {
2592             my $lrefname = lrfetchrefs.substr($rrefname, 4);
2593             my $got = $lrfetchrefs_f{$lrefname} // '<none>';
2594             my $want = $wantr{$rrefname};
2595             next if $got eq $want;
2596             if (!defined $objgot{$want}) {
2597                 print STDERR <<END;
2598 warning: git ls-remote suggests we want $lrefname
2599 warning:  and it should refer to $want
2600 warning:  but git fetch didn't fetch that object to any relevant ref.
2601 warning:  This may be due to a race with someone updating the server.
2602 warning:  Will try again...
2603 END
2604                 next FETCH_ITERATION;
2605             }
2606             printdebug <<END;
2607 git-fetch @fspecs made $lrefname=$got but want git ls-remote @look says $want
2608 END
2609             runcmd_ordryrun_local @git, qw(update-ref -m),
2610                 "dgit fetch git fetch fixup", $lrefname, $want;
2611             $lrfetchrefs_f{$lrefname} = $want;
2612         }
2613         last;
2614     }
2615     printdebug "git_fetch_us: git fetch --no-insane emulation complete\n",
2616         Dumper(\%lrfetchrefs_f);
2617
2618     my %here;
2619     my @tagpats = debiantags('*',access_nomdistro);
2620
2621     git_for_each_ref([map { "refs/tags/$_" } @tagpats], sub {
2622         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2623         printdebug "currently $fullrefname=$objid\n";
2624         $here{$fullrefname} = $objid;
2625     });
2626     git_for_each_ref([map { lrfetchrefs."/tags/".$_ } @tagpats], sub {
2627         my ($objid,$objtype,$fullrefname,$reftail) = @_;
2628         my $lref = "refs".substr($fullrefname, length(lrfetchrefs));
2629         printdebug "offered $lref=$objid\n";
2630         if (!defined $here{$lref}) {
2631             my @upd = (@git, qw(update-ref), $lref, $objid, '');
2632             runcmd_ordryrun_local @upd;
2633             lrfetchref_used $fullrefname;
2634         } elsif ($here{$lref} eq $objid) {
2635             lrfetchref_used $fullrefname;
2636         } else {
2637             print STDERR \
2638                 "Not updateting $lref from $here{$lref} to $objid.\n";
2639         }
2640     });
2641 }
2642
2643 sub mergeinfo_getclogp ($) {
2644     # Ensures thit $mi->{Clogp} exists and returns it
2645     my ($mi) = @_;
2646     $mi->{Clogp} = commit_getclogp($mi->{Commit});
2647 }
2648
2649 sub mergeinfo_version ($) {
2650     return getfield( (mergeinfo_getclogp $_[0]), 'Version' );
2651 }
2652
2653 sub fetch_from_archive () {
2654     ensure_setup_existing_tree();
2655
2656     # Ensures that lrref() is what is actually in the archive, one way
2657     # or another, according to us - ie this client's
2658     # appropritaely-updated archive view.  Also returns the commit id.
2659     # If there is nothing in the archive, leaves lrref alone and
2660     # returns undef.  git_fetch_us must have already been called.
2661     get_archive_dsc();
2662
2663     if ($dsc) {
2664         foreach my $field (@ourdscfield) {
2665             $dsc_hash = $dsc->{$field};
2666             last if defined $dsc_hash;
2667         }
2668         if (defined $dsc_hash) {
2669             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
2670             $dsc_hash = $&;
2671             progress "last upload to archive specified git hash";
2672         } else {
2673             progress "last upload to archive has NO git hash";
2674         }
2675     } else {
2676         progress "no version available from the archive";
2677     }
2678
2679     # If the archive's .dsc has a Dgit field, there are three
2680     # relevant git commitids we need to choose between and/or merge
2681     # together:
2682     #   1. $dsc_hash: the Dgit field from the archive
2683     #   2. $lastpush_hash: the suite branch on the dgit git server
2684     #   3. $lastfetch_hash: our local tracking brach for the suite
2685     #
2686     # These may all be distinct and need not be in any fast forward
2687     # relationship:
2688     #
2689     # If the dsc was pushed to this suite, then the server suite
2690     # branch will have been updated; but it might have been pushed to
2691     # a different suite and copied by the archive.  Conversely a more
2692     # recent version may have been pushed with dgit but not appeared
2693     # in the archive (yet).
2694     #
2695     # $lastfetch_hash may be awkward because archive imports
2696     # (particularly, imports of Dgit-less .dscs) are performed only as
2697     # needed on individual clients, so different clients may perform a
2698     # different subset of them - and these imports are only made
2699     # public during push.  So $lastfetch_hash may represent a set of
2700     # imports different to a subsequent upload by a different dgit
2701     # client.
2702     #
2703     # Our approach is as follows:
2704     #
2705     # As between $dsc_hash and $lastpush_hash: if $lastpush_hash is a
2706     # descendant of $dsc_hash, then it was pushed by a dgit user who
2707     # had based their work on $dsc_hash, so we should prefer it.
2708     # Otherwise, $dsc_hash was installed into this suite in the
2709     # archive other than by a dgit push, and (necessarily) after the
2710     # last dgit push into that suite (since a dgit push would have
2711     # been descended from the dgit server git branch); thus, in that
2712     # case, we prefer the archive's version (and produce a
2713     # pseudo-merge to overwrite the dgit server git branch).
2714     #
2715     # (If there is no Dgit field in the archive's .dsc then
2716     # generate_commit_from_dsc uses the version numbers to decide
2717     # whether the suite branch or the archive is newer.  If the suite
2718     # branch is newer it ignores the archive's .dsc; otherwise it
2719     # generates an import of the .dsc, and produces a pseudo-merge to
2720     # overwrite the suite branch with the archive contents.)
2721     #
2722     # The outcome of that part of the algorithm is the `public view',
2723     # and is same for all dgit clients: it does not depend on any
2724     # unpublished history in the local tracking branch.
2725     #
2726     # As between the public view and the local tracking branch: The
2727     # local tracking branch is only updated by dgit fetch, and
2728     # whenever dgit fetch runs it includes the public view in the
2729     # local tracking branch.  Therefore if the public view is not
2730     # descended from the local tracking branch, the local tracking
2731     # branch must contain history which was imported from the archive
2732     # but never pushed; and, its tip is now out of date.  So, we make
2733     # a pseudo-merge to overwrite the old imports and stitch the old
2734     # history in.
2735     #
2736     # Finally: we do not necessarily reify the public view (as
2737     # described above).  This is so that we do not end up stacking two
2738     # pseudo-merges.  So what we actually do is figure out the inputs
2739     # to any public view pseudo-merge and put them in @mergeinputs.
2740
2741     my @mergeinputs;
2742     # $mergeinputs[]{Commit}
2743     # $mergeinputs[]{Info}
2744     # $mergeinputs[0] is the one whose tree we use
2745     # @mergeinputs is in the order we use in the actual commit)
2746     #
2747     # Also:
2748     # $mergeinputs[]{Message} is a commit message to use
2749     # $mergeinputs[]{ReverseParents} if def specifies that parent
2750     #                                list should be in opposite order
2751     # Such an entry has no Commit or Info.  It applies only when found
2752     # in the last entry.  (This ugliness is to support making
2753     # identical imports to previous dgit versions.)
2754
2755     my $lastpush_hash = git_get_ref(lrfetchref());
2756     printdebug "previous reference hash=$lastpush_hash\n";
2757     $lastpush_mergeinput = $lastpush_hash && {
2758         Commit => $lastpush_hash,
2759         Info => "dgit suite branch on dgit git server",
2760     };
2761
2762     my $lastfetch_hash = git_get_ref(lrref());
2763     printdebug "fetch_from_archive: lastfetch=$lastfetch_hash\n";
2764     my $lastfetch_mergeinput = $lastfetch_hash && {
2765         Commit => $lastfetch_hash,
2766         Info => "dgit client's archive history view",
2767     };
2768
2769     my $dsc_mergeinput = $dsc_hash && {
2770         Commit => $dsc_hash,
2771         Info => "Dgit field in .dsc from archive",
2772     };
2773
2774     my $cwd = getcwd();
2775     my $del_lrfetchrefs = sub {
2776         changedir $cwd;
2777         my $gur;
2778         printdebug "del_lrfetchrefs...\n";
2779         foreach my $fullrefname (sort keys %lrfetchrefs_d) {
2780             my $objid = $lrfetchrefs_d{$fullrefname};
2781             printdebug "del_lrfetchrefs: $objid $fullrefname\n";
2782             if (!$gur) {
2783                 $gur ||= new IO::Handle;
2784                 open $gur, "|-", qw(git update-ref --stdin) or die $!;
2785             }
2786             printf $gur "delete %s %s\n", $fullrefname, $objid;
2787         }
2788         if ($gur) {
2789             close $gur or failedcmd "git update-ref delete lrfetchrefs";
2790         }
2791     };
2792
2793     if (defined $dsc_hash) {
2794         ensure_we_have_orig();
2795         if (!$lastpush_hash || $dsc_hash eq $lastpush_hash) {
2796             @mergeinputs = $dsc_mergeinput
2797         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
2798             print STDERR <<END or die $!;
2799
2800 Git commit in archive is behind the last version allegedly pushed/uploaded.
2801 Commit referred to by archive: $dsc_hash
2802 Last version pushed with dgit: $lastpush_hash
2803 $later_warning_msg
2804 END
2805             @mergeinputs = ($lastpush_mergeinput);
2806         } else {
2807             # Archive has .dsc which is not a descendant of the last dgit
2808             # push.  This can happen if the archive moves .dscs about.
2809             # Just follow its lead.
2810             if (is_fast_fwd($lastpush_hash,$dsc_hash)) {
2811                 progress "archive .dsc names newer git commit";
2812                 @mergeinputs = ($dsc_mergeinput);
2813             } else {
2814                 progress "archive .dsc names other git commit, fixing up";
2815                 @mergeinputs = ($dsc_mergeinput, $lastpush_mergeinput);
2816             }
2817         }
2818     } elsif ($dsc) {
2819         @mergeinputs = generate_commits_from_dsc();
2820         # We have just done an import.  Now, our import algorithm might
2821         # have been improved.  But even so we do not want to generate
2822         # a new different import of the same package.  So if the
2823         # version numbers are the same, just use our existing version.
2824         # If the version numbers are different, the archive has changed
2825         # (perhaps, rewound).
2826         if ($lastfetch_mergeinput &&
2827             !version_compare( (mergeinfo_version $lastfetch_mergeinput),
2828                               (mergeinfo_version $mergeinputs[0]) )) {
2829             @mergeinputs = ($lastfetch_mergeinput);
2830         }
2831     } elsif ($lastpush_hash) {
2832         # only in git, not in the archive yet
2833         @mergeinputs = ($lastpush_mergeinput);
2834         print STDERR <<END or die $!;
2835
2836 Package not found in the archive, but has allegedly been pushed using dgit.
2837 $later_warning_msg
2838 END
2839     } else {
2840         printdebug "nothing found!\n";
2841         if (defined $skew_warning_vsn) {
2842             print STDERR <<END or die $!;
2843
2844 Warning: relevant archive skew detected.
2845 Archive allegedly contains $skew_warning_vsn
2846 But we were not able to obtain any version from the archive or git.
2847
2848 END
2849         }
2850         unshift @end, $del_lrfetchrefs;
2851         return undef;
2852     }
2853
2854     if ($lastfetch_hash &&
2855         !grep {
2856             my $h = $_->{Commit};
2857             $h and is_fast_fwd($lastfetch_hash, $h);
2858             # If true, one of the existing parents of this commit
2859             # is a descendant of the $lastfetch_hash, so we'll
2860             # be ff from that automatically.
2861         } @mergeinputs
2862         ) {
2863         # Otherwise:
2864         push @mergeinputs, $lastfetch_mergeinput;
2865     }
2866
2867     printdebug "fetch mergeinfos:\n";
2868     foreach my $mi (@mergeinputs) {
2869         if ($mi->{Info}) {
2870             printdebug " commit $mi->{Commit} $mi->{Info}\n";
2871         } else {
2872             printdebug sprintf " ReverseParents=%d Message=%s",
2873                 $mi->{ReverseParents}, $mi->{Message};
2874         }
2875     }
2876
2877     my $compat_info= pop @mergeinputs
2878         if $mergeinputs[$#mergeinputs]{Message};
2879
2880     @mergeinputs = grep { defined $_->{Commit} } @mergeinputs;
2881
2882     my $hash;
2883     if (@mergeinputs > 1) {
2884         # here we go, then:
2885         my $tree_commit = $mergeinputs[0]{Commit};
2886
2887         my $tree = cmdoutput @git, qw(cat-file commit), $tree_commit;
2888         $tree =~ m/\n\n/;  $tree = $`;
2889         $tree =~ m/^tree (\w+)$/m or die "$dsc_hash tree ?";
2890         $tree = $1;
2891
2892         # We use the changelog author of the package in question the
2893         # author of this pseudo-merge.  This is (roughly) correct if
2894         # this commit is simply representing aa non-dgit upload.
2895         # (Roughly because it does not record sponsorship - but we
2896         # don't have sponsorship info because that's in the .changes,
2897         # which isn't in the archivw.)
2898         #
2899         # But, it might be that we are representing archive history
2900         # updates (including in-archive copies).  These are not really
2901         # the responsibility of the person who created the .dsc, but
2902         # there is no-one whose name we should better use.  (The
2903         # author of the .dsc-named commit is clearly worse.)
2904
2905         my $useclogp = mergeinfo_getclogp $mergeinputs[0];
2906         my $author = clogp_authline $useclogp;
2907         my $cversion = getfield $useclogp, 'Version';
2908
2909         my $mcf = ".git/dgit/mergecommit";
2910         open MC, ">", $mcf or die "$mcf $!";
2911         print MC <<END or die $!;
2912 tree $tree
2913 END
2914
2915         my @parents = grep { $_->{Commit} } @mergeinputs;
2916         @parents = reverse @parents if $compat_info->{ReverseParents};
2917         print MC <<END or die $! foreach @parents;
2918 parent $_->{Commit}
2919 END
2920
2921         print MC <<END or die $!;
2922 author $author
2923 committer $author
2924
2925 END
2926
2927         if (defined $compat_info->{Message}) {
2928             print MC $compat_info->{Message} or die $!;
2929         } else {
2930             print MC <<END or die $!;
2931 Record $package ($cversion) in archive suite $csuite
2932
2933 Record that
2934 END
2935             my $message_add_info = sub {
2936                 my ($mi) = (@_);
2937                 my $mversion = mergeinfo_version $mi;
2938                 printf MC "  %-20s %s\n", $mversion, $mi->{Info}
2939                     or die $!;
2940             };
2941
2942             $message_add_info->($mergeinputs[0]);
2943             print MC <<END or die $!;
2944 should be treated as descended from
2945 END
2946             $message_add_info->($_) foreach @mergeinputs[1..$#mergeinputs];
2947         }
2948
2949         close MC or die $!;
2950         $hash = make_commit $mcf;
2951     } else {
2952         $hash = $mergeinputs[0]{Commit};
2953     }
2954     printdebug "fetch hash=$hash\n";
2955
2956     my $chkff = sub {
2957         my ($lasth, $what) = @_;
2958         return unless $lasth;
2959         die "$lasth $hash $what ?" unless is_fast_fwd($lasth, $hash);
2960     };
2961
2962     $chkff->($lastpush_hash, 'dgit repo server tip (last push)')
2963         if $lastpush_hash;
2964     $chkff->($lastfetch_hash, 'local tracking tip (last fetch)');
2965
2966     runcmd @git, qw(update-ref -m), "dgit fetch $csuite",
2967             'DGIT_ARCHIVE', $hash;
2968     cmdoutput @git, qw(log -n2), $hash;
2969     # ... gives git a chance to complain if our commit is malformed
2970
2971     if (defined $skew_warning_vsn) {
2972         mkpath '.git/dgit';
2973         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
2974         my $gotclogp = commit_getclogp($hash);
2975         my $got_vsn = getfield $gotclogp, 'Version';
2976         printdebug "SKEW CHECK GOT $got_vsn\n";
2977         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
2978             print STDERR <<END or die $!;
2979
2980 Warning: archive skew detected.  Using the available version:
2981 Archive allegedly contains    $skew_warning_vsn
2982 We were able to obtain only   $got_vsn
2983
2984 END
2985         }
2986     }
2987
2988     if ($lastfetch_hash ne $hash) {
2989         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
2990         if (act_local()) {
2991             cmdoutput @upd_cmd;
2992         } else {
2993             dryrun_report @upd_cmd;
2994         }
2995     }
2996
2997     lrfetchref_used lrfetchref();
2998
2999     unshift @end, $del_lrfetchrefs;
3000     return $hash;
3001 }
3002
3003 sub set_local_git_config ($$) {
3004     my ($k, $v) = @_;
3005     runcmd @git, qw(config), $k, $v;
3006 }
3007
3008 sub setup_mergechangelogs (;$) {
3009     my ($always) = @_;
3010     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
3011
3012     my $driver = 'dpkg-mergechangelogs';
3013     my $cb = "merge.$driver";
3014     my $attrs = '.git/info/attributes';
3015     ensuredir '.git/info';
3016
3017     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
3018     if (!open ATTRS, "<", $attrs) {
3019         $!==ENOENT or die "$attrs: $!";
3020     } else {
3021         while (<ATTRS>) {
3022             chomp;
3023             next if m{^debian/changelog\s};
3024             print NATTRS $_, "\n" or die $!;
3025         }
3026         ATTRS->error and die $!;
3027         close ATTRS;
3028     }
3029     print NATTRS "debian/changelog merge=$driver\n" or die $!;
3030     close NATTRS;
3031
3032     set_local_git_config "$cb.name", 'debian/changelog merge driver';
3033     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
3034
3035     rename "$attrs.new", "$attrs" or die "$attrs: $!";
3036 }
3037
3038 sub setup_useremail (;$) {
3039     my ($always) = @_;
3040     return unless $always || access_cfg_bool(1, 'setup-useremail');
3041
3042     my $setup = sub {
3043         my ($k, $envvar) = @_;
3044         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
3045         return unless defined $v;
3046         set_local_git_config "user.$k", $v;
3047     };
3048
3049     $setup->('email', 'DEBEMAIL');
3050     $setup->('name', 'DEBFULLNAME');
3051 }
3052
3053 sub ensure_setup_existing_tree () {
3054     my $k = "remote.$remotename.skipdefaultupdate";
3055     my $c = git_get_config $k;
3056     return if defined $c;
3057     set_local_git_config $k, 'true';
3058 }
3059
3060 sub setup_new_tree () {
3061     setup_mergechangelogs();
3062     setup_useremail();
3063 }
3064
3065 sub clone ($) {
3066     my ($dstdir) = @_;
3067     canonicalise_suite();
3068     badusage "dry run makes no sense with clone" unless act_local();
3069     my $hasgit = check_for_git();
3070     mkdir $dstdir or fail "create \`$dstdir': $!";
3071     changedir $dstdir;
3072     runcmd @git, qw(init -q);
3073     my $giturl = access_giturl(1);
3074     if (defined $giturl) {
3075         open H, "> .git/HEAD" or die $!;
3076         print H "ref: ".lref()."\n" or die $!;
3077         close H or die $!;
3078         runcmd @git, qw(remote add), 'origin', $giturl;
3079     }
3080     if ($hasgit) {
3081         progress "fetching existing git history";
3082         git_fetch_us();
3083         runcmd_ordryrun_local @git, qw(fetch origin);
3084     } else {
3085         progress "starting new git history";
3086     }
3087     fetch_from_archive() or no_such_package;
3088     my $vcsgiturl = $dsc->{'Vcs-Git'};
3089     if (length $vcsgiturl) {
3090         $vcsgiturl =~ s/\s+-b\s+\S+//g;
3091         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
3092     }
3093     setup_new_tree();
3094     runcmd @git, qw(reset --hard), lrref();
3095     runcmd qw(bash -ec), <<'END';
3096         set -o pipefail
3097         git ls-tree -r --name-only -z HEAD | \
3098         xargs -0r touch -r . --
3099 END
3100     printdone "ready for work in $dstdir";
3101 }
3102
3103 sub fetch () {
3104     if (check_for_git()) {
3105         git_fetch_us();
3106     }
3107     fetch_from_archive() or no_such_package();
3108     printdone "fetched into ".lrref();
3109 }
3110
3111 sub pull () {
3112     fetch();
3113     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
3114         lrref();
3115     printdone "fetched to ".lrref()." and merged into HEAD";
3116 }
3117
3118 sub check_not_dirty () {
3119     foreach my $f (qw(local-options local-patch-header)) {
3120         if (stat_exists "debian/source/$f") {
3121             fail "git tree contains debian/source/$f";
3122         }
3123     }
3124
3125     return if $ignoredirty;
3126
3127     my @cmd = (@git, qw(diff --quiet HEAD));
3128     debugcmd "+",@cmd;
3129     $!=0; $?=-1; system @cmd;
3130     return if !$?;
3131     if ($?==256) {
3132         fail "working tree is dirty (does not match HEAD)";
3133     } else {
3134         failedcmd @cmd;
3135     }
3136 }
3137
3138 sub commit_admin ($) {
3139     my ($m) = @_;
3140     progress "$m";
3141     runcmd_ordryrun_local @git, qw(commit -m), $m;
3142 }
3143
3144 sub commit_quilty_patch () {
3145     my $output = cmdoutput @git, qw(status --porcelain);
3146     my %adds;
3147     foreach my $l (split /\n/, $output) {
3148         next unless $l =~ m/\S/;
3149         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
3150             $adds{$1}++;
3151         }
3152     }
3153     delete $adds{'.pc'}; # if there wasn't one before, don't add it
3154     if (!%adds) {
3155         progress "nothing quilty to commit, ok.";
3156         return;
3157     }
3158     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
3159     runcmd_ordryrun_local @git, qw(add -f), @adds;
3160     commit_admin <<END
3161 Commit Debian 3.0 (quilt) metadata
3162
3163 [dgit ($our_version) quilt-fixup]
3164 END
3165 }
3166
3167 sub get_source_format () {
3168     my %options;
3169     if (open F, "debian/source/options") {
3170         while (<F>) {
3171             next if m/^\s*\#/;
3172             next unless m/\S/;
3173             s/\s+$//; # ignore missing final newline
3174             if (m/\s*\#\s*/) {
3175                 my ($k, $v) = ($`, $'); #');
3176                 $v =~ s/^"(.*)"$/$1/;
3177                 $options{$k} = $v;
3178             } else {
3179                 $options{$_} = 1;
3180             }
3181         }
3182         F->error and die $!;
3183         close F;
3184     } else {
3185         die $! unless $!==&ENOENT;
3186     }
3187
3188     if (!open F, "debian/source/format") {
3189         die $! unless $!==&ENOENT;
3190         return '';
3191     }
3192     $_ = <F>;
3193     F->error and die $!;
3194     chomp;
3195     return ($_, \%options);
3196 }
3197
3198 sub madformat_wantfixup ($) {
3199     my ($format) = @_;
3200     return 0 unless $format eq '3.0 (quilt)';
3201     our $quilt_mode_warned;
3202     if ($quilt_mode eq 'nocheck') {
3203         progress "Not doing any fixup of \`$format' due to".
3204             " ----no-quilt-fixup or --quilt=nocheck"
3205             unless $quilt_mode_warned++;
3206         return 0;
3207     }
3208     progress "Format \`$format', need to check/update patch stack"
3209         unless $quilt_mode_warned++;
3210     return 1;
3211 }
3212
3213 sub maybe_split_brain_save ($$$) {
3214     my ($headref, $dgitview, $msg) = @_;
3215     # => message fragment "$saved" describing disposition of $dgitview
3216     return "commit id $dgitview" unless defined $split_brain_save;
3217     my @cmd = (shell_cmd "cd ../../../..",
3218                @git, qw(update-ref -m),
3219                "dgit --dgit-view-save $msg HEAD=$headref",
3220                $split_brain_save, $dgitview);
3221     runcmd @cmd;
3222     return "and left in $split_brain_save";
3223 }
3224
3225 # An "infopair" is a tuple [ $thing, $what ]
3226 # (often $thing is a commit hash; $what is a description)
3227
3228 sub infopair_cond_equal ($$) {
3229     my ($x,$y) = @_;
3230     $x->[0] eq $y->[0] or fail <<END;
3231 $x->[1] ($x->[0]) not equal to $y->[1] ($y->[0])
3232 END
3233 };
3234
3235 sub infopair_lrf_tag_lookup ($$) {
3236     my ($tagnames, $what) = @_;
3237     # $tagname may be an array ref
3238     my @tagnames = ref $tagnames ? @$tagnames : ($tagnames);
3239     printdebug "infopair_lrfetchref_tag_lookup $what @tagnames\n";
3240     foreach my $tagname (@tagnames) {
3241         my $lrefname = lrfetchrefs."/tags/$tagname";
3242         my $tagobj = $lrfetchrefs_f{$lrefname};
3243         next unless defined $tagobj;
3244         printdebug "infopair_lrfetchref_tag_lookup $tagobj $tagname $what\n";
3245         return [ git_rev_parse($tagobj), $what ];
3246     }
3247     fail @tagnames==1 ? <<END : <<END;
3248 Wanted tag $what (@tagnames) on dgit server, but not found
3249 END
3250 Wanted tag $what (one of: @tagnames) on dgit server, but not found
3251 END
3252 }
3253
3254 sub infopair_cond_ff ($$) {
3255     my ($anc,$desc) = @_;
3256     is_fast_fwd($anc->[0], $desc->[0]) or fail <<END;
3257 $anc->[1] ($anc->[0]) .. $desc->[1] ($desc->[0]) is not fast forward
3258 END
3259 };
3260
3261 sub pseudomerge_version_check ($$) {
3262     my ($clogp, $archive_hash) = @_;
3263
3264     my $arch_clogp = commit_getclogp $archive_hash;
3265     my $i_arch_v = [ (getfield $arch_clogp, 'Version'),
3266                      'version currently in archive' ];
3267     if (defined $overwrite_version) {
3268         if (length $overwrite_version) {
3269             infopair_cond_equal([ $overwrite_version,
3270                                   '--overwrite= version' ],
3271                                 $i_arch_v);
3272         } else {
3273             my $v = $i_arch_v->[0];
3274             progress "Checking package changelog for archive version $v ...";
3275             eval {
3276                 my @xa = ("-f$v", "-t$v");
3277                 my $vclogp = parsechangelog @xa;
3278                 my $cv = [ (getfield $vclogp, 'Version'),
3279                            "Version field from dpkg-parsechangelog @xa" ];
3280                 infopair_cond_equal($i_arch_v, $cv);
3281             };
3282             if ($@) {
3283                 $@ =~ s/^dgit: //gm;
3284                 fail "$@".
3285                     "Perhaps debian/changelog does not mention $v ?";
3286             }
3287         }
3288     }
3289     
3290     printdebug "pseudomerge_version_check i_arch_v @$i_arch_v\n";
3291     return $i_arch_v;
3292 }
3293
3294 sub pseudomerge_make_commit ($$$$ $$) {
3295     my ($clogp, $dgitview, $archive_hash, $i_arch_v,
3296         $msg_cmd, $msg_msg) = @_;
3297     progress "Declaring that HEAD inciudes all changes in $i_arch_v->[0]...";
3298
3299     my $tree = cmdoutput qw(git rev-parse), "${dgitview}:";
3300     my $authline = clogp_authline $clogp;
3301
3302     chomp $msg_msg;
3303     $msg_cmd .=
3304         !defined $overwrite_version ? ""
3305         : !length  $overwrite_version ? " --overwrite"
3306         : " --overwrite=".$overwrite_version;
3307
3308     mkpath '.git/dgit';
3309     my $pmf = ".git/dgit/pseudomerge";
3310     open MC, ">", $pmf or die "$pmf $!";
3311     print MC <<END or die $!;
3312 tree $tree
3313 parent $dgitview
3314 parent $archive_hash
3315 author $authline
3316 commiter $authline
3317
3318 $msg_msg
3319
3320 [$msg_cmd]
3321 END
3322     close MC or die $!;
3323
3324     return make_commit($pmf);
3325 }
3326
3327 sub splitbrain_pseudomerge ($$$$) {
3328     my ($clogp, $maintview, $dgitview, $archive_hash) = @_;
3329     # => $merged_dgitview
3330     printdebug "splitbrain_pseudomerge...\n";
3331     #
3332     #     We:      debian/PREVIOUS    HEAD($maintview)
3333     # expect:          o ----------------- o
3334     #                    \                   \
3335     #                     o                   o
3336     #                 a/d/PREVIOUS        $dgitview
3337     #                $archive_hash              \
3338     #  If so,                \                   \
3339     #  we do:                 `------------------ o
3340     #   this:                                   $dgitview'
3341     #
3342
3343     return $dgitview unless defined $archive_hash;
3344
3345     printdebug "splitbrain_pseudomerge...\n";
3346
3347     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3348
3349     if (!defined $overwrite_version) {
3350         progress "Checking that HEAD inciudes all changes in archive...";
3351     }
3352
3353     return $dgitview if is_fast_fwd $archive_hash, $dgitview;
3354
3355     if (defined $overwrite_version) {
3356     } elsif (!eval {
3357         my $t_dep14 = debiantag_maintview $i_arch_v->[0], access_nomdistro;
3358         my $i_dep14 = infopair_lrf_tag_lookup($t_dep14, "maintainer view tag");
3359         my $t_dgit = debiantag_new $i_arch_v->[0], access_nomdistro;
3360         my $i_dgit = infopair_lrf_tag_lookup($t_dgit, "dgit view tag");
3361         my $i_archive = [ $archive_hash, "current archive contents" ];
3362
3363         printdebug "splitbrain_pseudomerge i_archive @$i_archive\n";
3364
3365         infopair_cond_equal($i_dgit, $i_archive);
3366         infopair_cond_ff($i_dep14, $i_dgit);
3367         infopair_cond_ff($i_dep14, [ $maintview, 'HEAD' ]);
3368         1;
3369     }) {
3370         print STDERR <<END;
3371 $us: check failed (maybe --overwrite is needed, consult documentation)
3372 END
3373         die "$@";
3374     }
3375
3376     my $r = pseudomerge_make_commit
3377         $clogp, $dgitview, $archive_hash, $i_arch_v,
3378         "dgit --quilt=$quilt_mode",
3379         (defined $overwrite_version ? <<END_OVERWR : <<END_MAKEFF);
3380 Declare fast forward from $i_arch_v->[0]
3381 END_OVERWR
3382 Make fast forward from $i_arch_v->[0]
3383 END_MAKEFF
3384
3385     maybe_split_brain_save $maintview, $r, "pseudomerge";
3386
3387     progress "Made pseudo-merge of $i_arch_v->[0] into dgit view.";
3388     return $r;
3389 }       
3390
3391 sub plain_overwrite_pseudomerge ($$$) {
3392     my ($clogp, $head, $archive_hash) = @_;
3393
3394     printdebug "plain_overwrite_pseudomerge...";
3395
3396     my $i_arch_v = pseudomerge_version_check($clogp, $archive_hash);
3397
3398     return $head if is_fast_fwd $archive_hash, $head;
3399
3400     my $m = "Declare fast forward from $i_arch_v->[0]";
3401
3402     my $r = pseudomerge_make_commit
3403         $clogp, $head, $archive_hash, $i_arch_v,
3404         "dgit", $m;
3405
3406     runcmd @git, qw(update-ref -m), $m, 'HEAD', $r, $head;
3407
3408     progress "Make pseudo-merge of $i_arch_v->[0] into your HEAD.";
3409     return $r;
3410 }
3411
3412 sub push_parse_changelog ($) {
3413     my ($clogpfn) = @_;
3414
3415     my $clogp = Dpkg::Control::Hash->new();
3416     $clogp->load($clogpfn) or die;
3417
3418     my $clogpackage = getfield $clogp, 'Source';
3419     $package //= $clogpackage;
3420     fail "-p specified $package but changelog specified $clogpackage"
3421         unless $package eq $clogpackage;
3422     my $cversion = getfield $clogp, 'Version';
3423     my $tag = debiantag($cversion, access_nomdistro);
3424     runcmd @git, qw(check-ref-format), $tag;
3425
3426     my $dscfn = dscfn($cversion);
3427
3428     return ($clogp, $cversion, $dscfn);
3429 }
3430
3431 sub push_parse_dsc ($$$) {
3432     my ($dscfn,$dscfnwhat, $cversion) = @_;
3433     $dsc = parsecontrol($dscfn,$dscfnwhat);
3434     my $dversion = getfield $dsc, 'Version';
3435     my $dscpackage = getfield $dsc, 'Source';
3436     ($dscpackage eq $package && $dversion eq $cversion) or
3437         fail "$dscfn is for $dscpackage $dversion".
3438             " but debian/changelog is for $package $cversion";
3439 }
3440
3441 sub push_tagwants ($$$$) {
3442     my ($cversion, $dgithead, $maintviewhead, $tfbase) = @_;
3443     my @tagwants;
3444     push @tagwants, {
3445         TagFn => \&debiantag,
3446         Objid => $dgithead,
3447         TfSuffix => '',
3448         View => 'dgit',
3449     };
3450     if (defined $maintviewhead) {
3451         push @tagwants, {
3452             TagFn => \&debiantag_maintview,
3453             Objid => $maintviewhead,
3454             TfSuffix => '-maintview',
3455             View => 'maint',
3456         };
3457     }
3458     foreach my $tw (@tagwants) {
3459         $tw->{Tag} = $tw->{TagFn}($cversion, access_nomdistro);
3460         $tw->{Tfn} = sub { $tfbase.$tw->{TfSuffix}.$_[0]; };
3461     }
3462     printdebug 'push_tagwants: ', Dumper(\@_, \@tagwants);
3463     return @tagwants;
3464 }
3465
3466 sub push_mktags ($$ $$ $) {
3467     my ($clogp,$dscfn,
3468         $changesfile,$changesfilewhat,
3469         $tagwants) = @_;
3470
3471     die unless $tagwants->[0]{View} eq 'dgit';
3472
3473     $dsc->{$ourdscfield[0]} = $tagwants->[0]{Objid};
3474     $dsc->save("$dscfn.tmp") or die $!;
3475
3476     my $changes = parsecontrol($changesfile,$changesfilewhat);
3477     foreach my $field (qw(Source Distribution Version)) {
3478         $changes->{$field} eq $clogp->{$field} or
3479             fail "changes field $field \`$changes->{$field}'".
3480                 " does not match changelog \`$clogp->{$field}'";
3481     }
3482
3483     my $cversion = getfield $clogp, 'Version';
3484     my $clogsuite = getfield $clogp, 'Distribution';
3485
3486     # We make the git tag by hand because (a) that makes it easier
3487     # to control the "tagger" (b) we can do remote signing
3488     my $authline = clogp_authline $clogp;
3489     my $delibs = join(" ", "",@deliberatelies);
3490     my $declaredistro = access_nomdistro();
3491
3492     my $mktag = sub {
3493         my ($tw) = @_;
3494         my $tfn = $tw->{Tfn};
3495         my $head = $tw->{Objid};
3496         my $tag = $tw->{Tag};
3497
3498         open TO, '>', $tfn->('.tmp') or die $!;
3499         print TO <<END or die $!;
3500 object $head
3501 type commit
3502 tag $tag
3503 tagger $authline
3504
3505 END
3506         if ($tw->{View} eq 'dgit') {
3507             print TO <<END or die $!;
3508 $package release $cversion for $clogsuite ($csuite) [dgit]
3509 [dgit distro=$declaredistro$delibs]
3510 END
3511             foreach my $ref (sort keys %previously) {
3512                 print TO <<END or die $!;
3513 [dgit previously:$ref=$previously{$ref}]
3514 END
3515             }
3516         } elsif ($tw->{View} eq 'maint') {
3517             print TO <<END or die $!;
3518 $package release $cversion for $clogsuite ($csuite)
3519 (maintainer view tag generated by dgit --quilt=$quilt_mode)
3520 END
3521         } else {
3522             die Dumper($tw)."?";
3523         }
3524
3525         close TO or die $!;
3526
3527         my $tagobjfn = $tfn->('.tmp');
3528         if ($sign) {
3529             if (!defined $keyid) {
3530                 $keyid = access_cfg('keyid','RETURN-UNDEF');
3531             }
3532             if (!defined $keyid) {
3533                 $keyid = getfield $clogp, 'Maintainer';
3534             }
3535             unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
3536             my @sign_cmd = (@gpg, qw(--detach-sign --armor));
3537             push @sign_cmd, qw(-u),$keyid if defined $keyid;
3538             push @sign_cmd, $tfn->('.tmp');
3539             runcmd_ordryrun @sign_cmd;
3540             if (act_scary()) {
3541                 $tagobjfn = $tfn->('.signed.tmp');
3542                 runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
3543                     $tfn->('.tmp'), $tfn->('.tmp.asc');
3544             }
3545         }
3546         return $tagobjfn;
3547     };
3548
3549     my @r = map { $mktag->($_); } @$tagwants;
3550     return @r;
3551 }
3552
3553 sub sign_changes ($) {
3554     my ($changesfile) = @_;
3555     if ($sign) {
3556         my @debsign_cmd = @debsign;
3557         push @debsign_cmd, "-k$keyid" if defined $keyid;
3558         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
3559         push @debsign_cmd, $changesfile;
3560         runcmd_ordryrun @debsign_cmd;
3561     }
3562 }
3563
3564 sub dopush () {
3565     printdebug "actually entering push\n";
3566
3567     supplementary_message(<<'END');
3568 Push failed, while checking state of the archive.
3569 You can retry the push, after fixing the problem, if you like.
3570 END
3571     if (check_for_git()) {
3572         git_fetch_us();
3573     }
3574     my $archive_hash = fetch_from_archive();
3575     if (!$archive_hash) {
3576         $new_package or
3577             fail "package appears to be new in this suite;".
3578                 " if this is intentional, use --new";
3579     }
3580
3581     supplementary_message(<<'END');
3582 Push failed, while preparing your push.
3583 You can retry the push, after fixing the problem, if you like.
3584 END
3585
3586     need_tagformat 'new', "quilt mode $quilt_mode"
3587         if quiltmode_splitbrain;
3588
3589     prep_ud();
3590
3591     access_giturl(); # check that success is vaguely likely
3592     select_tagformat();
3593
3594     my $clogpfn = ".git/dgit/changelog.822.tmp";
3595     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
3596
3597     responder_send_file('parsed-changelog', $clogpfn);
3598
3599     my ($clogp, $cversion, $dscfn) =
3600         push_parse_changelog("$clogpfn");
3601
3602     my $dscpath = "$buildproductsdir/$dscfn";
3603     stat_exists $dscpath or
3604         fail "looked for .dsc $dscfn, but $!;".
3605             " maybe you forgot to build";
3606
3607     responder_send_file('dsc', $dscpath);
3608
3609     push_parse_dsc($dscpath, $dscfn, $cversion);
3610
3611     my $format = getfield $dsc, 'Format';
3612     printdebug "format $format\n";
3613
3614     my $actualhead = git_rev_parse('HEAD');
3615     my $dgithead = $actualhead;
3616     my $maintviewhead = undef;
3617
3618     my $upstreamversion = upstreamversion $clogp->{Version};
3619
3620     if (madformat_wantfixup($format)) {
3621         # user might have not used dgit build, so maybe do this now:
3622         if (quiltmode_splitbrain()) {
3623             changedir $ud;
3624             quilt_make_fake_dsc($upstreamversion);
3625             my $cachekey;
3626             ($dgithead, $cachekey) =
3627                 quilt_check_splitbrain_cache($actualhead, $upstreamversion);
3628             $dgithead or fail
3629  "--quilt=$quilt_mode but no cached dgit view:
3630  perhaps tree changed since dgit build[-source] ?";
3631             $split_brain = 1;
3632             $dgithead = splitbrain_pseudomerge($clogp,
3633                                                $actualhead, $dgithead,
3634                                                $archive_hash);
3635             $maintviewhead = $actualhead;
3636             changedir '../../../..';
3637             prep_ud(); # so _only_subdir() works, below
3638         } else {
3639             commit_quilty_patch();
3640         }
3641     }
3642
3643     if (defined $overwrite_version && !defined $maintviewhead) {
3644         $dgithead = plain_overwrite_pseudomerge($clogp,
3645                                                 $dgithead,
3646                                                 $archive_hash);
3647     }
3648
3649     check_not_dirty();
3650
3651     my $forceflag = '';
3652     if ($archive_hash) {
3653         if (is_fast_fwd($archive_hash, $dgithead)) {
3654             # ok
3655         } elsif (deliberately_not_fast_forward) {
3656             $forceflag = '+';
3657         } else {
3658             fail "dgit push: HEAD is not a descendant".
3659                 " of the archive's version.\n".
3660                 "To overwrite the archive's contents,".
3661                 " pass --overwrite[=VERSION].\n".
3662                 "To rewind history, if permitted by the archive,".
3663                 " use --deliberately-not-fast-forward.";
3664         }
3665     }
3666
3667     changedir $ud;
3668     progress "checking that $dscfn corresponds to HEAD";
3669     runcmd qw(dpkg-source -x --),
3670         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
3671     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
3672     check_for_vendor_patches() if madformat($dsc->{format});
3673     changedir '../../../..';
3674     my @diffcmd = (@git, qw(diff --quiet), $tree, $dgithead);
3675     debugcmd "+",@diffcmd;
3676     $!=0; $?=-1;
3677     my $r = system @diffcmd;
3678     if ($r) {
3679         if ($r==256) {
3680             my $diffs = cmdoutput @git, qw(diff --stat), $tree, $dgithead;
3681             fail <<END
3682 HEAD specifies a different tree to $dscfn:
3683 $diffs
3684 Perhaps you forgot to build.  Or perhaps there is a problem with your
3685  source tree (see dgit(7) for some hints).  To see a full diff, run
3686    git diff $tree HEAD
3687 END
3688         } else {
3689             failedcmd @diffcmd;
3690         }
3691     }
3692     if (!$changesfile) {
3693         my $pat = changespat $cversion;
3694         my @cs = glob "$buildproductsdir/$pat";
3695         fail "failed to find unique changes file".
3696             " (looked for $pat in $buildproductsdir);".
3697             " perhaps you need to use dgit -C"
3698             unless @cs==1;
3699         ($changesfile) = @cs;
3700     } else {
3701         $changesfile = "$buildproductsdir/$changesfile";
3702     }
3703
3704     # Check that changes and .dsc agree enough
3705     $changesfile =~ m{[^/]*$};
3706     my $changes = parsecontrol($changesfile,$&);
3707     files_compare_inputs($dsc, $changes)
3708         unless forceing [qw(dsc-changes-mismatch)];
3709
3710     # Perhaps adjust .dsc to contain right set of origs
3711     changes_update_origs_from_dsc($dsc, $changes, $upstreamversion,
3712                                   $changesfile)
3713         unless forceing [qw(changes-origs-exactly)];
3714
3715     # Checks complete, we're going to try and go ahead:
3716
3717     responder_send_file('changes',$changesfile);
3718     responder_send_command("param head $dgithead");
3719     responder_send_command("param csuite $csuite");