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