dgit

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