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