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