dgit

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