dgit

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