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