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