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