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