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