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