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 =~ m/^\S+ (404|200) /s or
1161             fail "unexpected results from git check query - ".
1162                 Dumper($prefix, $result);
1163         my $code = $1;
1164         if ($code eq '404') {
1165             return 0;
1166         } elsif ($code eq '200') {
1167             return 1;
1168         } else {
1169             die;
1170         }
1171     } elsif ($how eq 'true') {
1172         return 1;
1173     } elsif ($how eq 'false') {
1174         return 0;
1175     } else {
1176         badcfg "unknown git-check \`$how'";
1177     }
1178 }
1179
1180 sub create_remote_git_repo () {
1181     my $how = access_cfg('git-create');
1182     if ($how eq 'ssh-cmd') {
1183         runcmd_ordryrun
1184             (access_cfg_ssh, access_gituserhost(),
1185              access_runeinfo("git-create $package").
1186              "set -e; cd ".access_cfg('git-path').";".
1187              " cp -a _template $package.git");
1188     } elsif ($how eq 'true') {
1189         # nothing to do
1190     } else {
1191         badcfg "unknown git-create \`$how'";
1192     }
1193 }
1194
1195 our ($dsc_hash,$lastpush_hash);
1196
1197 our $ud = '.git/dgit/unpack';
1198
1199 sub prep_ud () {
1200     rmtree($ud);
1201     mkpath '.git/dgit';
1202     mkdir $ud or die $!;
1203 }
1204
1205 sub mktree_in_ud_here () {
1206     runcmd qw(git init -q);
1207     rmtree('.git/objects');
1208     symlink '../../../../objects','.git/objects' or die $!;
1209 }
1210
1211 sub git_write_tree () {
1212     my $tree = cmdoutput @git, qw(write-tree);
1213     $tree =~ m/^\w+$/ or die "$tree ?";
1214     return $tree;
1215 }
1216
1217 sub mktree_in_ud_from_only_subdir () {
1218     # changes into the subdir
1219     my (@dirs) = <*/.>;
1220     die unless @dirs==1;
1221     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1222     my $dir = $1;
1223     changedir $dir;
1224
1225     my @gitscmd = qw(find -name .git -prune -print0);
1226     debugcmd "|",@gitscmd;
1227     open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1228     {
1229         local $/="\0";
1230         while (<GITS>) {
1231             chomp or die;
1232             print STDERR "$us: warning: removing from source package: ",
1233                 (messagequote $_), "\n";
1234             rmtree $_;
1235         }
1236     }
1237     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1238
1239     mktree_in_ud_here();
1240     my $format=get_source_format();
1241     if (madformat($format)) {
1242         rmtree '.pc';
1243     }
1244     runcmd @git, qw(add -Af);
1245     my $tree=git_write_tree();
1246     return ($tree,$dir);
1247 }
1248
1249 sub dsc_files_info () {
1250     foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1251                        ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1252                        ['Files',           'Digest::MD5', 'new()']) {
1253         my ($fname, $module, $method) = @$csumi;
1254         my $field = $dsc->{$fname};
1255         next unless defined $field;
1256         eval "use $module; 1;" or die $@;
1257         my @out;
1258         foreach (split /\n/, $field) {
1259             next unless m/\S/;
1260             m/^(\w+) (\d+) (\S+)$/ or
1261                 fail "could not parse .dsc $fname line \`$_'";
1262             my $digester = eval "$module"."->$method;" or die $@;
1263             push @out, {
1264                 Hash => $1,
1265                 Bytes => $2,
1266                 Filename => $3,
1267                 Digester => $digester,
1268             };
1269         }
1270         return @out;
1271     }
1272     fail "missing any supported Checksums-* or Files field in ".
1273         $dsc->get_option('name');
1274 }
1275
1276 sub dsc_files () {
1277     map { $_->{Filename} } dsc_files_info();
1278 }
1279
1280 sub is_orig_file ($;$) {
1281     local ($_) = $_[0];
1282     my $base = $_[1];
1283     m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1284     defined $base or return 1;
1285     return $` eq $base;
1286 }
1287
1288 sub make_commit ($) {
1289     my ($file) = @_;
1290     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1291 }
1292
1293 sub clogp_authline ($) {
1294     my ($clogp) = @_;
1295     my $author = getfield $clogp, 'Maintainer';
1296     $author =~ s#,.*##ms;
1297     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1298     my $authline = "$author $date";
1299     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1300         fail "unexpected commit author line format \`$authline'".
1301         " (was generated from changelog Maintainer field)";
1302     return $authline;
1303 }
1304
1305 sub vendor_patches_distro ($$) {
1306     my ($checkdistro, $what) = @_;
1307     return unless defined $checkdistro;
1308
1309     my $series = "debian/patches/\L$checkdistro\E.series";
1310     printdebug "checking for vendor-specific $series ($what)\n";
1311
1312     if (!open SERIES, "<", $series) {
1313         die "$series $!" unless $!==ENOENT;
1314         return;
1315     }
1316     while (<SERIES>) {
1317         next unless m/\S/;
1318         next if m/^\s+\#/;
1319
1320         print STDERR <<END;
1321
1322 Unfortunately, this source package uses a feature of dpkg-source where
1323 the same source package unpacks to different source code on different
1324 distros.  dgit cannot safely operate on such packages on affected
1325 distros, because the meaning of source packages is not stable.
1326
1327 Please ask the distro/maintainer to remove the distro-specific series
1328 files and use a different technique (if necessary, uploading actually
1329 different packages, if different distros are supposed to have
1330 different code).
1331
1332 END
1333         fail "Found active distro-specific series file for".
1334             " $checkdistro ($what): $series, cannot continue";
1335     }
1336     die "$series $!" if SERIES->error;
1337     close SERIES;
1338 }
1339
1340 sub check_for_vendor_patches () {
1341     # This dpkg-source feature doesn't seem to be documented anywhere!
1342     # But it can be found in the changelog (reformatted):
1343
1344     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1345     #   Author: Raphael Hertzog <hertzog@debian.org>
1346     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1347
1348     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1349     #   series files
1350     #
1351     #   If you have debian/patches/ubuntu.series and you were
1352     #   unpacking the source package on ubuntu, quilt was still
1353     #   directed to debian/patches/series instead of
1354     #   debian/patches/ubuntu.series.
1355     #
1356     #   debian/changelog                        |    3 +++
1357     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1358     #   2 files changed, 6 insertions(+), 1 deletion(-)
1359
1360     use Dpkg::Vendor;
1361     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1362     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1363                          "Dpkg::Vendor \`current vendor'");
1364     vendor_patches_distro(access_basedistro(),
1365                           "distro being accessed");
1366 }
1367
1368 sub generate_commit_from_dsc () {
1369     prep_ud();
1370     changedir $ud;
1371
1372     foreach my $fi (dsc_files_info()) {
1373         my $f = $fi->{Filename};
1374         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1375
1376         link "../../../$f", $f
1377             or $!==&ENOENT
1378             or die "$f $!";
1379
1380         complete_file_from_dsc('.', $fi);
1381
1382         if (is_orig_file($f)) {
1383             link $f, "../../../../$f"
1384                 or $!==&EEXIST
1385                 or die "$f $!";
1386         }
1387     }
1388
1389     my $dscfn = "$package.dsc";
1390
1391     open D, ">", $dscfn or die "$dscfn: $!";
1392     print D $dscdata or die "$dscfn: $!";
1393     close D or die "$dscfn: $!";
1394     my @cmd = qw(dpkg-source);
1395     push @cmd, '--no-check' if $dsc_checked;
1396     push @cmd, qw(-x --), $dscfn;
1397     runcmd @cmd;
1398
1399     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1400     check_for_vendor_patches() if madformat($dsc->{format});
1401     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1402     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1403     my $authline = clogp_authline $clogp;
1404     my $changes = getfield $clogp, 'Changes';
1405     open C, ">../commit.tmp" or die $!;
1406     print C <<END or die $!;
1407 tree $tree
1408 author $authline
1409 committer $authline
1410
1411 $changes
1412
1413 # imported from the archive
1414 END
1415     close C or die $!;
1416     my $outputhash = make_commit qw(../commit.tmp);
1417     my $cversion = getfield $clogp, 'Version';
1418     progress "synthesised git commit from .dsc $cversion";
1419     if ($lastpush_hash) {
1420         runcmd @git, qw(reset --hard), $lastpush_hash;
1421         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1422         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1423         my $oversion = getfield $oldclogp, 'Version';
1424         my $vcmp =
1425             version_compare($oversion, $cversion);
1426         if ($vcmp < 0) {
1427             # git upload/ is earlier vsn than archive, use archive
1428             open C, ">../commit2.tmp" or die $!;
1429             print C <<END or die $!;
1430 tree $tree
1431 parent $lastpush_hash
1432 parent $outputhash
1433 author $authline
1434 committer $authline
1435
1436 Record $package ($cversion) in archive suite $csuite
1437 END
1438             $outputhash = make_commit qw(../commit2.tmp);
1439         } elsif ($vcmp > 0) {
1440             print STDERR <<END or die $!;
1441
1442 Version actually in archive:    $cversion (older)
1443 Last allegedly pushed/uploaded: $oversion (newer or same)
1444 $later_warning_msg
1445 END
1446             $outputhash = $lastpush_hash;
1447         } else {
1448             $outputhash = $lastpush_hash;
1449         }
1450     }
1451     changedir '../../../..';
1452     runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1453             'DGIT_ARCHIVE', $outputhash;
1454     cmdoutput @git, qw(log -n2), $outputhash;
1455     # ... gives git a chance to complain if our commit is malformed
1456     rmtree($ud);
1457     return $outputhash;
1458 }
1459
1460 sub complete_file_from_dsc ($$) {
1461     our ($dstdir, $fi) = @_;
1462     # Ensures that we have, in $dir, the file $fi, with the correct
1463     # contents.  (Downloading it from alongside $dscurl if necessary.)
1464
1465     my $f = $fi->{Filename};
1466     my $tf = "$dstdir/$f";
1467     my $downloaded = 0;
1468
1469     if (stat_exists $tf) {
1470         progress "using existing $f";
1471     } else {
1472         my $furl = $dscurl;
1473         $furl =~ s{/[^/]+$}{};
1474         $furl .= "/$f";
1475         die "$f ?" unless $f =~ m/^${package}_/;
1476         die "$f ?" if $f =~ m#/#;
1477         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1478         next if !act_local();
1479         $downloaded = 1;
1480     }
1481
1482     open F, "<", "$tf" or die "$tf: $!";
1483     $fi->{Digester}->reset();
1484     $fi->{Digester}->addfile(*F);
1485     F->error and die $!;
1486     my $got = $fi->{Digester}->hexdigest();
1487     $got eq $fi->{Hash} or
1488         fail "file $f has hash $got but .dsc".
1489             " demands hash $fi->{Hash} ".
1490             ($downloaded ? "(got wrong file from archive!)"
1491              : "(perhaps you should delete this file?)");
1492 }
1493
1494 sub ensure_we_have_orig () {
1495     foreach my $fi (dsc_files_info()) {
1496         my $f = $fi->{Filename};
1497         next unless is_orig_file($f);
1498         complete_file_from_dsc('..', $fi);
1499     }
1500 }
1501
1502 sub git_fetch_us () {
1503     my @specs = (fetchspec());
1504     push @specs,
1505         map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1506         qw(tags heads);
1507     runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1508
1509     my %here;
1510     my $tagpat = debiantag('*',access_basedistro);
1511
1512     git_for_each_ref("refs/tags/".$tagpat, sub {
1513         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1514         printdebug "currently $fullrefname=$objid\n";
1515         $here{$fullrefname} = $objid;
1516     });
1517     git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1518         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1519         my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1520         printdebug "offered $lref=$objid\n";
1521         if (!defined $here{$lref}) {
1522             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1523             runcmd_ordryrun_local @upd;
1524         } elsif ($here{$lref} eq $objid) {
1525         } else {
1526             print STDERR \
1527                 "Not updateting $lref from $here{$lref} to $objid.\n";
1528         }
1529     });
1530 }
1531
1532 sub fetch_from_archive () {
1533     # ensures that lrref() is what is actually in the archive,
1534     #  one way or another
1535     get_archive_dsc();
1536
1537     if ($dsc) {
1538         foreach my $field (@ourdscfield) {
1539             $dsc_hash = $dsc->{$field};
1540             last if defined $dsc_hash;
1541         }
1542         if (defined $dsc_hash) {
1543             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1544             $dsc_hash = $&;
1545             progress "last upload to archive specified git hash";
1546         } else {
1547             progress "last upload to archive has NO git hash";
1548         }
1549     } else {
1550         progress "no version available from the archive";
1551     }
1552
1553     $lastpush_hash = git_get_ref(lrref());
1554     printdebug "previous reference hash=$lastpush_hash\n";
1555     my $hash;
1556     if (defined $dsc_hash) {
1557         fail "missing remote git history even though dsc has hash -".
1558             " could not find ref ".lrref().
1559             " (should have been fetched from ".access_giturl()."#".rrref().")"
1560             unless $lastpush_hash;
1561         $hash = $dsc_hash;
1562         ensure_we_have_orig();
1563         if ($dsc_hash eq $lastpush_hash) {
1564         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1565             print STDERR <<END or die $!;
1566
1567 Git commit in archive is behind the last version allegedly pushed/uploaded.
1568 Commit referred to by archive:  $dsc_hash
1569 Last allegedly pushed/uploaded: $lastpush_hash
1570 $later_warning_msg
1571 END
1572             $hash = $lastpush_hash;
1573         } else {
1574             fail "git head (".lrref()."=$lastpush_hash) is not a ".
1575                 "descendant of archive's .dsc hash ($dsc_hash)";
1576         }
1577     } elsif ($dsc) {
1578         $hash = generate_commit_from_dsc();
1579     } elsif ($lastpush_hash) {
1580         # only in git, not in the archive yet
1581         $hash = $lastpush_hash;
1582         print STDERR <<END or die $!;
1583
1584 Package not found in the archive, but has allegedly been pushed using dgit.
1585 $later_warning_msg
1586 END
1587     } else {
1588         printdebug "nothing found!\n";
1589         if (defined $skew_warning_vsn) {
1590             print STDERR <<END or die $!;
1591
1592 Warning: relevant archive skew detected.
1593 Archive allegedly contains $skew_warning_vsn
1594 But we were not able to obtain any version from the archive or git.
1595
1596 END
1597         }
1598         return 0;
1599     }
1600     printdebug "current hash=$hash\n";
1601     if ($lastpush_hash) {
1602         fail "not fast forward on last upload branch!".
1603             " (archive's version left in DGIT_ARCHIVE)"
1604             unless is_fast_fwd($lastpush_hash, $hash);
1605     }
1606     if (defined $skew_warning_vsn) {
1607         mkpath '.git/dgit';
1608         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1609         my $clogf = ".git/dgit/changelog.tmp";
1610         runcmd shell_cmd "exec >$clogf",
1611             @git, qw(cat-file blob), "$hash:debian/changelog";
1612         my $gotclogp = parsechangelog("-l$clogf");
1613         my $got_vsn = getfield $gotclogp, 'Version';
1614         printdebug "SKEW CHECK GOT $got_vsn\n";
1615         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1616             print STDERR <<END or die $!;
1617
1618 Warning: archive skew detected.  Using the available version:
1619 Archive allegedly contains    $skew_warning_vsn
1620 We were able to obtain only   $got_vsn
1621
1622 END
1623         }
1624     }
1625     if ($lastpush_hash ne $hash) {
1626         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1627         if (act_local()) {
1628             cmdoutput @upd_cmd;
1629         } else {
1630             dryrun_report @upd_cmd;
1631         }
1632     }
1633     return 1;
1634 }
1635
1636 sub set_local_git_config ($$) {
1637     my ($k, $v) = @_;
1638     runcmd @git, qw(config), $k, $v;
1639 }
1640
1641 sub setup_mergechangelogs (;$) {
1642     my ($always) = @_;
1643     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1644
1645     my $driver = 'dpkg-mergechangelogs';
1646     my $cb = "merge.$driver";
1647     my $attrs = '.git/info/attributes';
1648     ensuredir '.git/info';
1649
1650     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1651     if (!open ATTRS, "<", $attrs) {
1652         $!==ENOENT or die "$attrs: $!";
1653     } else {
1654         while (<ATTRS>) {
1655             chomp;
1656             next if m{^debian/changelog\s};
1657             print NATTRS $_, "\n" or die $!;
1658         }
1659         ATTRS->error and die $!;
1660         close ATTRS;
1661     }
1662     print NATTRS "debian/changelog merge=$driver\n" or die $!;
1663     close NATTRS;
1664
1665     set_local_git_config "$cb.name", 'debian/changelog merge driver';
1666     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1667
1668     rename "$attrs.new", "$attrs" or die "$attrs: $!";
1669 }
1670
1671 sub setup_useremail (;$) {
1672     my ($always) = @_;
1673     return unless $always || access_cfg_bool(1, 'setup-useremail');
1674
1675     my $setup = sub {
1676         my ($k, $envvar) = @_;
1677         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1678         return unless defined $v;
1679         set_local_git_config "user.$k", $v;
1680     };
1681
1682     $setup->('email', 'DEBEMAIL');
1683     $setup->('name', 'DEBFULLNAME');
1684 }
1685
1686 sub setup_new_tree () {
1687     setup_mergechangelogs();
1688     setup_useremail();
1689 }
1690
1691 sub clone ($) {
1692     my ($dstdir) = @_;
1693     canonicalise_suite();
1694     badusage "dry run makes no sense with clone" unless act_local();
1695     my $hasgit = check_for_git();
1696     mkdir $dstdir or die "$dstdir $!";
1697     changedir $dstdir;
1698     runcmd @git, qw(init -q);
1699     my $giturl = access_giturl(1);
1700     if (defined $giturl) {
1701         set_local_git_config "remote.$remotename.fetch", fetchspec();
1702         open H, "> .git/HEAD" or die $!;
1703         print H "ref: ".lref()."\n" or die $!;
1704         close H or die $!;
1705         runcmd @git, qw(remote add), 'origin', $giturl;
1706     }
1707     if ($hasgit) {
1708         progress "fetching existing git history";
1709         git_fetch_us();
1710         runcmd_ordryrun_local @git, qw(fetch origin);
1711     } else {
1712         progress "starting new git history";
1713     }
1714     fetch_from_archive() or no_such_package;
1715     my $vcsgiturl = $dsc->{'Vcs-Git'};
1716     if (length $vcsgiturl) {
1717         $vcsgiturl =~ s/\s+-b\s+\S+//g;
1718         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1719     }
1720     setup_new_tree();
1721     runcmd @git, qw(reset --hard), lrref();
1722     printdone "ready for work in $dstdir";
1723 }
1724
1725 sub fetch () {
1726     if (check_for_git()) {
1727         git_fetch_us();
1728     }
1729     fetch_from_archive() or no_such_package();
1730     printdone "fetched into ".lrref();
1731 }
1732
1733 sub pull () {
1734     fetch();
1735     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1736         lrref();
1737     printdone "fetched to ".lrref()." and merged into HEAD";
1738 }
1739
1740 sub check_not_dirty () {
1741     return if $ignoredirty;
1742     my @cmd = (@git, qw(diff --quiet HEAD));
1743     debugcmd "+",@cmd;
1744     $!=0; $?=0; system @cmd;
1745     return if !$! && !$?;
1746     if (!$! && $?==256) {
1747         fail "working tree is dirty (does not match HEAD)";
1748     } else {
1749         failedcmd @cmd;
1750     }
1751 }
1752
1753 sub commit_admin ($) {
1754     my ($m) = @_;
1755     progress "$m";
1756     runcmd_ordryrun_local @git, qw(commit -m), $m;
1757 }
1758
1759 sub commit_quilty_patch () {
1760     my $output = cmdoutput @git, qw(status --porcelain);
1761     my %adds;
1762     foreach my $l (split /\n/, $output) {
1763         next unless $l =~ m/\S/;
1764         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1765             $adds{$1}++;
1766         }
1767     }
1768     delete $adds{'.pc'}; # if there wasn't one before, don't add it
1769     if (!%adds) {
1770         progress "nothing quilty to commit, ok.";
1771         return;
1772     }
1773     runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1774     commit_admin "Commit Debian 3.0 (quilt) metadata";
1775 }
1776
1777 sub get_source_format () {
1778     if (!open F, "debian/source/format") {
1779         die $! unless $!==&ENOENT;
1780         return '';
1781     }
1782     $_ = <F>;
1783     F->error and die $!;
1784     chomp;
1785     return $_;
1786 }
1787
1788 sub madformat ($) {
1789     my ($format) = @_;
1790     return 0 unless $format eq '3.0 (quilt)';
1791     if ($quilt_mode eq 'nocheck') {
1792         progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1793         return 0;
1794     }
1795     progress "Format \`$format', checking/updating patch stack";
1796     return 1;
1797 }
1798
1799 sub push_parse_changelog ($) {
1800     my ($clogpfn) = @_;
1801
1802     my $clogp = Dpkg::Control::Hash->new();
1803     $clogp->load($clogpfn) or die;
1804
1805     $package = getfield $clogp, 'Source';
1806     my $cversion = getfield $clogp, 'Version';
1807     my $tag = debiantag($cversion, access_basedistro);
1808     runcmd @git, qw(check-ref-format), $tag;
1809
1810     my $dscfn = dscfn($cversion);
1811
1812     return ($clogp, $cversion, $tag, $dscfn);
1813 }
1814
1815 sub push_parse_dsc ($$$) {
1816     my ($dscfn,$dscfnwhat, $cversion) = @_;
1817     $dsc = parsecontrol($dscfn,$dscfnwhat);
1818     my $dversion = getfield $dsc, 'Version';
1819     my $dscpackage = getfield $dsc, 'Source';
1820     ($dscpackage eq $package && $dversion eq $cversion) or
1821         fail "$dscfn is for $dscpackage $dversion".
1822             " but debian/changelog is for $package $cversion";
1823 }
1824
1825 sub push_mktag ($$$$$$$) {
1826     my ($head,$clogp,$tag,
1827         $dscfn,
1828         $changesfile,$changesfilewhat,
1829         $tfn) = @_;
1830
1831     $dsc->{$ourdscfield[0]} = $head;
1832     $dsc->save("$dscfn.tmp") or die $!;
1833
1834     my $changes = parsecontrol($changesfile,$changesfilewhat);
1835     foreach my $field (qw(Source Distribution Version)) {
1836         $changes->{$field} eq $clogp->{$field} or
1837             fail "changes field $field \`$changes->{$field}'".
1838                 " does not match changelog \`$clogp->{$field}'";
1839     }
1840
1841     my $cversion = getfield $clogp, 'Version';
1842     my $clogsuite = getfield $clogp, 'Distribution';
1843
1844     # We make the git tag by hand because (a) that makes it easier
1845     # to control the "tagger" (b) we can do remote signing
1846     my $authline = clogp_authline $clogp;
1847     my $delibs = join(" ", "",@deliberatelies);
1848     my $declaredistro = access_basedistro();
1849     open TO, '>', $tfn->('.tmp') or die $!;
1850     print TO <<END or die $!;
1851 object $head
1852 type commit
1853 tag $tag
1854 tagger $authline
1855
1856 $package release $cversion for $clogsuite ($csuite) [dgit]
1857 [dgit distro=$declaredistro$delibs]
1858 END
1859     foreach my $ref (sort keys %previously) {
1860                     print TO <<END or die $!;
1861 [dgit previously:$ref=$previously{$ref}]
1862 END
1863     }
1864
1865     close TO or die $!;
1866
1867     my $tagobjfn = $tfn->('.tmp');
1868     if ($sign) {
1869         if (!defined $keyid) {
1870             $keyid = access_cfg('keyid','RETURN-UNDEF');
1871         }
1872         unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1873         my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1874         push @sign_cmd, qw(-u),$keyid if defined $keyid;
1875         push @sign_cmd, $tfn->('.tmp');
1876         runcmd_ordryrun @sign_cmd;
1877         if (act_scary()) {
1878             $tagobjfn = $tfn->('.signed.tmp');
1879             runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1880                 $tfn->('.tmp'), $tfn->('.tmp.asc');
1881         }
1882     }
1883
1884     return ($tagobjfn);
1885 }
1886
1887 sub sign_changes ($) {
1888     my ($changesfile) = @_;
1889     if ($sign) {
1890         my @debsign_cmd = @debsign;
1891         push @debsign_cmd, "-k$keyid" if defined $keyid;
1892         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1893         push @debsign_cmd, $changesfile;
1894         runcmd_ordryrun @debsign_cmd;
1895     }
1896 }
1897
1898 sub dopush ($) {
1899     my ($forceflag) = @_;
1900     printdebug "actually entering push\n";
1901     supplementary_message(<<'END');
1902 Push failed, while preparing your push.
1903 You can retry the push, after fixing the problem, if you like.
1904 END
1905     prep_ud();
1906
1907     access_giturl(); # check that success is vaguely likely
1908
1909     my $clogpfn = ".git/dgit/changelog.822.tmp";
1910     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1911
1912     responder_send_file('parsed-changelog', $clogpfn);
1913
1914     my ($clogp, $cversion, $tag, $dscfn) =
1915         push_parse_changelog("$clogpfn");
1916
1917     my $dscpath = "$buildproductsdir/$dscfn";
1918     stat_exists $dscpath or
1919         fail "looked for .dsc $dscfn, but $!;".
1920             " maybe you forgot to build";
1921
1922     responder_send_file('dsc', $dscpath);
1923
1924     push_parse_dsc($dscpath, $dscfn, $cversion);
1925
1926     my $format = getfield $dsc, 'Format';
1927     printdebug "format $format\n";
1928     if (madformat($format)) {
1929         commit_quilty_patch();
1930     }
1931     check_not_dirty();
1932     changedir $ud;
1933     progress "checking that $dscfn corresponds to HEAD";
1934     runcmd qw(dpkg-source -x --),
1935         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1936     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1937     check_for_vendor_patches() if madformat($dsc->{format});
1938     changedir '../../../..';
1939     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1940     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1941     debugcmd "+",@diffcmd;
1942     $!=0; $?=0;
1943     my $r = system @diffcmd;
1944     if ($r) {
1945         if ($r==256) {
1946             fail "$dscfn specifies a different tree to your HEAD commit;".
1947                 " perhaps you forgot to build".
1948                 ($diffopt eq '--exit-code' ? "" :
1949                  " (run with -D to see full diff output)");
1950         } else {
1951             failedcmd @diffcmd;
1952         }
1953     }
1954     my $head = git_rev_parse('HEAD');
1955     if (!$changesfile) {
1956         my $multi = "$buildproductsdir/".
1957             "${package}_".(stripepoch $cversion)."_multi.changes";
1958         if (stat_exists "$multi") {
1959             $changesfile = $multi;
1960         } else {
1961             my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1962             my @cs = glob "$buildproductsdir/$pat";
1963             fail "failed to find unique changes file".
1964                 " (looked for $pat in $buildproductsdir, or $multi);".
1965                 " perhaps you need to use dgit -C"
1966                 unless @cs==1;
1967             ($changesfile) = @cs;
1968         }
1969     } else {
1970         $changesfile = "$buildproductsdir/$changesfile";
1971     }
1972
1973     responder_send_file('changes',$changesfile);
1974     responder_send_command("param head $head");
1975     responder_send_command("param csuite $csuite");
1976
1977     if (deliberately_not_fast_forward) {
1978         git_for_each_ref(lrfetchrefs, sub {
1979             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1980             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1981             responder_send_command("previously $rrefname=$objid");
1982             $previously{$rrefname} = $objid;
1983         });
1984     }
1985
1986     my $tfn = sub { ".git/dgit/tag$_[0]"; };
1987     my $tagobjfn;
1988
1989     supplementary_message(<<'END');
1990 Push failed, while signing the tag.
1991 You can retry the push, after fixing the problem, if you like.
1992 END
1993     # If we manage to sign but fail to record it anywhere, it's fine.
1994     if ($we_are_responder) {
1995         $tagobjfn = $tfn->('.signed.tmp');
1996         responder_receive_files('signed-tag', $tagobjfn);
1997     } else {
1998         $tagobjfn =
1999             push_mktag($head,$clogp,$tag,
2000                        $dscpath,
2001                        $changesfile,$changesfile,
2002                        $tfn);
2003     }
2004     supplementary_message(<<'END');
2005 Push failed, *after* signing the tag.
2006 If you want to try again, you should use a new version number.
2007 END
2008
2009     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2010     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2011     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2012
2013     supplementary_message(<<'END');
2014 Push failed, while updating the remote git repository - see messages above.
2015 If you want to try again, you should use a new version number.
2016 END
2017     if (!check_for_git()) {
2018         create_remote_git_repo();
2019     }
2020     runcmd_ordryrun @git, qw(push),access_giturl(),
2021         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2022     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2023
2024     supplementary_message(<<'END');
2025 Push failed, after updating the remote git repository.
2026 If you want to try again, you must use a new version number.
2027 END
2028     if ($we_are_responder) {
2029         my $dryrunsuffix = act_local() ? "" : ".tmp";
2030         responder_receive_files('signed-dsc-changes',
2031                                 "$dscpath$dryrunsuffix",
2032                                 "$changesfile$dryrunsuffix");
2033     } else {
2034         if (act_local()) {
2035             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2036         } else {
2037             progress "[new .dsc left in $dscpath.tmp]";
2038         }
2039         sign_changes $changesfile;
2040     }
2041
2042     supplementary_message(<<'END');
2043 Push failed, while uploading package(s) to the archive server.
2044 You can retry the upload of exactly these same files with dput of:
2045   $changesfile
2046 If that .changes file is broken, you will need to use a new version
2047 number for your next attempt at the upload.
2048 END
2049     my $host = access_cfg('upload-host','RETURN-UNDEF');
2050     my @hostarg = defined($host) ? ($host,) : ();
2051     runcmd_ordryrun @dput, @hostarg, $changesfile;
2052     printdone "pushed and uploaded $cversion";
2053
2054     supplementary_message('');
2055     responder_send_command("complete");
2056 }
2057
2058 sub cmd_clone {
2059     parseopts();
2060     notpushing();
2061     my $dstdir;
2062     badusage "-p is not allowed with clone; specify as argument instead"
2063         if defined $package;
2064     if (@ARGV==1) {
2065         ($package) = @ARGV;
2066     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2067         ($package,$isuite) = @ARGV;
2068     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2069         ($package,$dstdir) = @ARGV;
2070     } elsif (@ARGV==3) {
2071         ($package,$isuite,$dstdir) = @ARGV;
2072     } else {
2073         badusage "incorrect arguments to dgit clone";
2074     }
2075     $dstdir ||= "$package";
2076
2077     if (stat_exists $dstdir) {
2078         fail "$dstdir already exists";
2079     }
2080
2081     my $cwd_remove;
2082     if ($rmonerror && !$dryrun_level) {
2083         $cwd_remove= getcwd();
2084         unshift @end, sub {
2085             return unless defined $cwd_remove;
2086             if (!chdir "$cwd_remove") {
2087                 return if $!==&ENOENT;
2088                 die "chdir $cwd_remove: $!";
2089             }
2090             rmtree($dstdir) or die "remove $dstdir: $!\n";
2091         };
2092     }
2093
2094     clone($dstdir);
2095     $cwd_remove = undef;
2096 }
2097
2098 sub branchsuite () {
2099     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2100     if ($branch =~ m#$lbranch_re#o) {
2101         return $1;
2102     } else {
2103         return undef;
2104     }
2105 }
2106
2107 sub fetchpullargs () {
2108     notpushing();
2109     if (!defined $package) {
2110         my $sourcep = parsecontrol('debian/control','debian/control');
2111         $package = getfield $sourcep, 'Source';
2112     }
2113     if (@ARGV==0) {
2114 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2115         if (!$isuite) {
2116             my $clogp = parsechangelog();
2117             $isuite = getfield $clogp, 'Distribution';
2118         }
2119         canonicalise_suite();
2120         progress "fetching from suite $csuite";
2121     } elsif (@ARGV==1) {
2122         ($isuite) = @ARGV;
2123         canonicalise_suite();
2124     } else {
2125         badusage "incorrect arguments to dgit fetch or dgit pull";
2126     }
2127 }
2128
2129 sub cmd_fetch {
2130     parseopts();
2131     fetchpullargs();
2132     fetch();
2133 }
2134
2135 sub cmd_pull {
2136     parseopts();
2137     fetchpullargs();
2138     pull();
2139 }
2140
2141 sub cmd_push {
2142     parseopts();
2143     pushing();
2144     badusage "-p is not allowed with dgit push" if defined $package;
2145     check_not_dirty();
2146     my $clogp = parsechangelog();
2147     $package = getfield $clogp, 'Source';
2148     my $specsuite;
2149     if (@ARGV==0) {
2150     } elsif (@ARGV==1) {
2151         ($specsuite) = (@ARGV);
2152     } else {
2153         badusage "incorrect arguments to dgit push";
2154     }
2155     $isuite = getfield $clogp, 'Distribution';
2156     if ($new_package) {
2157         local ($package) = $existing_package; # this is a hack
2158         canonicalise_suite();
2159     } else {
2160         canonicalise_suite();
2161     }
2162     if (defined $specsuite &&
2163         $specsuite ne $isuite &&
2164         $specsuite ne $csuite) {
2165             fail "dgit push: changelog specifies $isuite ($csuite)".
2166                 " but command line specifies $specsuite";
2167     }
2168     supplementary_message(<<'END');
2169 Push failed, while checking state of the archive.
2170 You can retry the push, after fixing the problem, if you like.
2171 END
2172     if (check_for_git()) {
2173         git_fetch_us();
2174     }
2175     my $forceflag = '';
2176     if (fetch_from_archive()) {
2177         if (is_fast_fwd(lrref(), 'HEAD')) {
2178             # ok
2179         } elsif (deliberately_not_fast_forward) {
2180             $forceflag = '+';
2181         } else {
2182             fail "dgit push: HEAD is not a descendant".
2183                 " of the archive's version.\n".
2184                 "dgit: To overwrite its contents,".
2185                 " use git merge -s ours ".lrref().".\n".
2186                 "dgit: To rewind history, if permitted by the archive,".
2187                 " use --deliberately-not-fast-forward";
2188         }
2189     } else {
2190         $new_package or
2191             fail "package appears to be new in this suite;".
2192                 " if this is intentional, use --new";
2193     }
2194     dopush($forceflag);
2195 }
2196
2197 #---------- remote commands' implementation ----------
2198
2199 sub cmd_remote_push_build_host {
2200     my ($nrargs) = shift @ARGV;
2201     my (@rargs) = @ARGV[0..$nrargs-1];
2202     @ARGV = @ARGV[$nrargs..$#ARGV];
2203     die unless @rargs;
2204     my ($dir,$vsnwant) = @rargs;
2205     # vsnwant is a comma-separated list; we report which we have
2206     # chosen in our ready response (so other end can tell if they
2207     # offered several)
2208     $debugprefix = ' ';
2209     $we_are_responder = 1;
2210     $us .= " (build host)";
2211
2212     pushing();
2213
2214     open PI, "<&STDIN" or die $!;
2215     open STDIN, "/dev/null" or die $!;
2216     open PO, ">&STDOUT" or die $!;
2217     autoflush PO 1;
2218     open STDOUT, ">&STDERR" or die $!;
2219     autoflush STDOUT 1;
2220
2221     $vsnwant //= 1;
2222     ($protovsn) = grep {
2223         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2224     } @rpushprotovsn_support;
2225
2226     fail "build host has dgit rpush protocol versions ".
2227         (join ",", @rpushprotovsn_support).
2228         " but invocation host has $vsnwant"
2229         unless defined $protovsn;
2230
2231     responder_send_command("dgit-remote-push-ready $protovsn");
2232
2233     changedir $dir;
2234     &cmd_push;
2235 }
2236
2237 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2238 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2239 #     a good error message)
2240
2241 our $i_tmp;
2242
2243 sub i_cleanup {
2244     local ($@, $?);
2245     my $report = i_child_report();
2246     if (defined $report) {
2247         printdebug "($report)\n";
2248     } elsif ($i_child_pid) {
2249         printdebug "(killing build host child $i_child_pid)\n";
2250         kill 15, $i_child_pid;
2251     }
2252     if (defined $i_tmp && !defined $initiator_tempdir) {
2253         changedir "/";
2254         eval { rmtree $i_tmp; };
2255     }
2256 }
2257
2258 END { i_cleanup(); }
2259
2260 sub i_method {
2261     my ($base,$selector,@args) = @_;
2262     $selector =~ s/\-/_/g;
2263     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2264 }
2265
2266 sub cmd_rpush {
2267     pushing();
2268     my $host = nextarg;
2269     my $dir;
2270     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2271         $host = $1;
2272         $dir = $'; #';
2273     } else {
2274         $dir = nextarg;
2275     }
2276     $dir =~ s{^-}{./-};
2277     my @rargs = ($dir);
2278     push @rargs, join ",", @rpushprotovsn_support;
2279     my @rdgit;
2280     push @rdgit, @dgit;
2281     push @rdgit, @ropts;
2282     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2283     push @rdgit, @ARGV;
2284     my @cmd = (@ssh, $host, shellquote @rdgit);
2285     debugcmd "+",@cmd;
2286
2287     if (defined $initiator_tempdir) {
2288         rmtree $initiator_tempdir;
2289         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2290         $i_tmp = $initiator_tempdir;
2291     } else {
2292         $i_tmp = tempdir();
2293     }
2294     $i_child_pid = open2(\*RO, \*RI, @cmd);
2295     changedir $i_tmp;
2296     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2297     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2298     $supplementary_message = '' unless $protovsn >= 3;
2299     for (;;) {
2300         my ($icmd,$iargs) = initiator_expect {
2301             m/^(\S+)(?: (.*))?$/;
2302             ($1,$2);
2303         };
2304         i_method "i_resp", $icmd, $iargs;
2305     }
2306 }
2307
2308 sub i_resp_progress ($) {
2309     my ($rhs) = @_;
2310     my $msg = protocol_read_bytes \*RO, $rhs;
2311     progress $msg;
2312 }
2313
2314 sub i_resp_supplementary_message ($) {
2315     my ($rhs) = @_;
2316     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2317 }
2318
2319 sub i_resp_complete {
2320     my $pid = $i_child_pid;
2321     $i_child_pid = undef; # prevents killing some other process with same pid
2322     printdebug "waiting for build host child $pid...\n";
2323     my $got = waitpid $pid, 0;
2324     die $! unless $got == $pid;
2325     die "build host child failed $?" if $?;
2326
2327     i_cleanup();
2328     printdebug "all done\n";
2329     exit 0;
2330 }
2331
2332 sub i_resp_file ($) {
2333     my ($keyword) = @_;
2334     my $localname = i_method "i_localname", $keyword;
2335     my $localpath = "$i_tmp/$localname";
2336     stat_exists $localpath and
2337         badproto \*RO, "file $keyword ($localpath) twice";
2338     protocol_receive_file \*RO, $localpath;
2339     i_method "i_file", $keyword;
2340 }
2341
2342 our %i_param;
2343
2344 sub i_resp_param ($) {
2345     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2346     $i_param{$1} = $2;
2347 }
2348
2349 sub i_resp_previously ($) {
2350     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2351         or badproto \*RO, "bad previously spec";
2352     my $r = system qw(git check-ref-format), $1;
2353     die "bad previously ref spec ($r)" if $r;
2354     $previously{$1} = $2;
2355 }
2356
2357 our %i_wanted;
2358
2359 sub i_resp_want ($) {
2360     my ($keyword) = @_;
2361     die "$keyword ?" if $i_wanted{$keyword}++;
2362     my @localpaths = i_method "i_want", $keyword;
2363     printdebug "[[  $keyword @localpaths\n";
2364     foreach my $localpath (@localpaths) {
2365         protocol_send_file \*RI, $localpath;
2366     }
2367     print RI "files-end\n" or die $!;
2368 }
2369
2370 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2371
2372 sub i_localname_parsed_changelog {
2373     return "remote-changelog.822";
2374 }
2375 sub i_file_parsed_changelog {
2376     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2377         push_parse_changelog "$i_tmp/remote-changelog.822";
2378     die if $i_dscfn =~ m#/|^\W#;
2379 }
2380
2381 sub i_localname_dsc {
2382     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2383     return $i_dscfn;
2384 }
2385 sub i_file_dsc { }
2386
2387 sub i_localname_changes {
2388     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2389     $i_changesfn = $i_dscfn;
2390     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2391     return $i_changesfn;
2392 }
2393 sub i_file_changes { }
2394
2395 sub i_want_signed_tag {
2396     printdebug Dumper(\%i_param, $i_dscfn);
2397     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2398         && defined $i_param{'csuite'}
2399         or badproto \*RO, "premature desire for signed-tag";
2400     my $head = $i_param{'head'};
2401     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2402
2403     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2404     $csuite = $&;
2405     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2406
2407     my $tagobjfn =
2408         push_mktag $head, $i_clogp, $i_tag,
2409             $i_dscfn,
2410             $i_changesfn, 'remote changes',
2411             sub { "tag$_[0]"; };
2412
2413     return $tagobjfn;
2414 }
2415
2416 sub i_want_signed_dsc_changes {
2417     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2418     sign_changes $i_changesfn;
2419     return ($i_dscfn, $i_changesfn);
2420 }
2421
2422 #---------- building etc. ----------
2423
2424 our $version;
2425 our $sourcechanges;
2426 our $dscfn;
2427
2428 #----- `3.0 (quilt)' handling -----
2429
2430 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2431
2432 sub quiltify_dpkg_commit ($$$;$) {
2433     my ($patchname,$author,$msg, $xinfo) = @_;
2434     $xinfo //= '';
2435
2436     mkpath '.git/dgit';
2437     my $descfn = ".git/dgit/quilt-description.tmp";
2438     open O, '>', $descfn or die "$descfn: $!";
2439     $msg =~ s/\s+$//g;
2440     $msg =~ s/\n/\n /g;
2441     $msg =~ s/^\s+$/ ./mg;
2442     print O <<END or die $!;
2443 Description: $msg
2444 Author: $author
2445 $xinfo
2446 ---
2447
2448 END
2449     close O or die $!;
2450
2451     {
2452         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2453         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2454         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2455         runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2456     }
2457 }
2458
2459 sub quiltify_trees_differ ($$) {
2460     my ($x,$y) = @_;
2461     # returns 1 iff the two tree objects differ other than in debian/
2462     local $/=undef;
2463     my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2464     my $diffs= cmdoutput @cmd;
2465     foreach my $f (split /\0/, $diffs) {
2466         next if $f eq 'debian';
2467         return 1;
2468     }
2469     return 0;
2470 }
2471
2472 sub quiltify_tree_sentinelfiles ($) {
2473     # lists the `sentinel' files present in the tree
2474     my ($x) = @_;
2475     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2476         qw(-- debian/rules debian/control);
2477     $r =~ s/\n/,/g;
2478     return $r;
2479 }
2480
2481 sub quiltify ($$) {
2482     my ($clogp,$target) = @_;
2483
2484     # Quilt patchification algorithm
2485     #
2486     # We search backwards through the history of the main tree's HEAD
2487     # (T) looking for a start commit S whose tree object is identical
2488     # to to the patch tip tree (ie the tree corresponding to the
2489     # current dpkg-committed patch series).  For these purposes
2490     # `identical' disregards anything in debian/ - this wrinkle is
2491     # necessary because dpkg-source treates debian/ specially.
2492     #
2493     # We can only traverse edges where at most one of the ancestors'
2494     # trees differs (in changes outside in debian/).  And we cannot
2495     # handle edges which change .pc/ or debian/patches.  To avoid
2496     # going down a rathole we avoid traversing edges which introduce
2497     # debian/rules or debian/control.  And we set a limit on the
2498     # number of edges we are willing to look at.
2499     #
2500     # If we succeed, we walk forwards again.  For each traversed edge
2501     # PC (with P parent, C child) (starting with P=S and ending with
2502     # C=T) to we do this:
2503     #  - git checkout C
2504     #  - dpkg-source --commit with a patch name and message derived from C
2505     # After traversing PT, we git commit the changes which
2506     # should be contained within debian/patches.
2507
2508     changedir '../fake';
2509     mktree_in_ud_here();
2510     rmtree '.pc';
2511     runcmd @git, 'add', '.';
2512     my $oldtiptree=git_write_tree();
2513     changedir '../work';
2514
2515     # The search for the path S..T is breadth-first.  We maintain a
2516     # todo list containing search nodes.  A search node identifies a
2517     # commit, and looks something like this:
2518     #  $p = {
2519     #      Commit => $git_commit_id,
2520     #      Child => $c,                          # or undef if P=T
2521     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2522     #      Nontrivial => true iff $p..$c has relevant changes
2523     #  };
2524
2525     my @todo;
2526     my @nots;
2527     my $sref_S;
2528     my $max_work=100;
2529     my %considered; # saves being exponential on some weird graphs
2530
2531     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2532
2533     my $not = sub {
2534         my ($search,$whynot) = @_;
2535         printdebug " search NOT $search->{Commit} $whynot\n";
2536         $search->{Whynot} = $whynot;
2537         push @nots, $search;
2538         no warnings qw(exiting);
2539         next;
2540     };
2541
2542     push @todo, {
2543         Commit => $target,
2544     };
2545
2546     while (@todo) {
2547         my $c = shift @todo;
2548         next if $considered{$c->{Commit}}++;
2549
2550         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2551
2552         printdebug "quiltify investigate $c->{Commit}\n";
2553
2554         # are we done?
2555         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2556             printdebug " search finished hooray!\n";
2557             $sref_S = $c;
2558             last;
2559         }
2560
2561         if ($quilt_mode eq 'nofix') {
2562             fail "quilt fixup required but quilt mode is \`nofix'\n".
2563                 "HEAD commit $c->{Commit} differs from tree implied by ".
2564                 " debian/patches (tree object $oldtiptree)";
2565         }
2566         if ($quilt_mode eq 'smash') {
2567             printdebug " search quitting smash\n";
2568             last;
2569         }
2570
2571         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2572         $not->($c, "has $c_sentinels not $t_sentinels")
2573             if $c_sentinels ne $t_sentinels;
2574
2575         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2576         $commitdata =~ m/\n\n/;
2577         $commitdata =~ $`;
2578         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2579         @parents = map { { Commit => $_, Child => $c } } @parents;
2580
2581         $not->($c, "root commit") if !@parents;
2582
2583         foreach my $p (@parents) {
2584             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2585         }
2586         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2587         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2588
2589         foreach my $p (@parents) {
2590             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2591
2592             my @cmd= (@git, qw(diff-tree -r --name-only),
2593                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2594             my $patchstackchange = cmdoutput @cmd;
2595             if (length $patchstackchange) {
2596                 $patchstackchange =~ s/\n/,/g;
2597                 $not->($p, "changed $patchstackchange");
2598             }
2599
2600             printdebug " search queue P=$p->{Commit} ",
2601                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2602             push @todo, $p;
2603         }
2604     }
2605
2606     if (!$sref_S) {
2607         printdebug "quiltify want to smash\n";
2608
2609         my $abbrev = sub {
2610             my $x = $_[0]{Commit};
2611             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2612             return $;
2613         };
2614         my $reportnot = sub {
2615             my ($notp) = @_;
2616             my $s = $abbrev->($notp);
2617             my $c = $notp->{Child};
2618             $s .= "..".$abbrev->($c) if $c;
2619             $s .= ": ".$notp->{Whynot};
2620             return $s;
2621         };
2622         if ($quilt_mode eq 'linear') {
2623             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2624             foreach my $notp (@nots) {
2625                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2626             }
2627             fail "quilt fixup naive history linearisation failed.\n".
2628  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2629         } elsif ($quilt_mode eq 'smash') {
2630         } elsif ($quilt_mode eq 'auto') {
2631             progress "quilt fixup cannot be linear, smashing...";
2632         } else {
2633             die "$quilt_mode ?";
2634         }
2635
2636         my $time = time;
2637         my $ncommits = 3;
2638         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2639
2640         quiltify_dpkg_commit "auto-$version-$target-$time",
2641             (getfield $clogp, 'Maintainer'),
2642             "Automatically generated patch ($clogp->{Version})\n".
2643             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2644         return;
2645     }
2646
2647     progress "quiltify linearisation planning successful, executing...";
2648
2649     for (my $p = $sref_S;
2650          my $c = $p->{Child};
2651          $p = $p->{Child}) {
2652         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2653         next unless $p->{Nontrivial};
2654
2655         my $cc = $c->{Commit};
2656
2657         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2658         $commitdata =~ m/\n\n/ or die "$c ?";
2659         $commitdata = $`;
2660         my $msg = $'; #';
2661         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2662         my $author = $1;
2663
2664         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2665
2666         my $title = $1;
2667         my $patchname = $title;
2668         $patchname =~ s/[.:]$//;
2669         $patchname =~ y/ A-Z/-a-z/;
2670         $patchname =~ y/-a-z0-9_.+=~//cd;
2671         $patchname =~ s/^\W/x-$&/;
2672         $patchname = substr($patchname,0,40);
2673         my $index;
2674         for ($index='';
2675              stat "debian/patches/$patchname$index";
2676              $index++) { }
2677         $!==ENOENT or die "$patchname$index $!";
2678
2679         runcmd @git, qw(checkout -q), $cc;
2680
2681         # We use the tip's changelog so that dpkg-source doesn't
2682         # produce complaining messages from dpkg-parsechangelog.  None
2683         # of the information dpkg-source gets from the changelog is
2684         # actually relevant - it gets put into the original message
2685         # which dpkg-source provides our stunt editor, and then
2686         # overwritten.
2687         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2688
2689         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2690             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2691
2692         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2693     }
2694
2695     runcmd @git, qw(checkout -q master);
2696 }
2697
2698 sub build_maybe_quilt_fixup () {
2699     my $format=get_source_format;
2700     return unless madformat $format;
2701     # sigh
2702
2703     check_for_vendor_patches();
2704
2705     # Our objective is:
2706     #  - honour any existing .pc in case it has any strangeness
2707     #  - determine the git commit corresponding to the tip of
2708     #    the patch stack (if there is one)
2709     #  - if there is such a git commit, convert each subsequent
2710     #    git commit into a quilt patch with dpkg-source --commit
2711     #  - otherwise convert all the differences in the tree into
2712     #    a single git commit
2713     #
2714     # To do this we:
2715
2716     # Our git tree doesn't necessarily contain .pc.  (Some versions of
2717     # dgit would include the .pc in the git tree.)  If there isn't
2718     # one, we need to generate one by unpacking the patches that we
2719     # have.
2720     #
2721     # We first look for a .pc in the git tree.  If there is one, we
2722     # will use it.  (This is not the normal case.)
2723     #
2724     # Otherwise need to regenerate .pc so that dpkg-source --commit
2725     # can work.  We do this as follows:
2726     #     1. Collect all relevant .orig from parent directory
2727     #     2. Generate a debian.tar.gz out of
2728     #         debian/{patches,rules,source/format}
2729     #     3. Generate a fake .dsc containing just these fields:
2730     #          Format Source Version Files
2731     #     4. Extract the fake .dsc
2732     #        Now the fake .dsc has a .pc directory.
2733     # (In fact we do this in every case, because in future we will
2734     # want to search for a good base commit for generating patches.)
2735     #
2736     # Then we can actually do the dpkg-source --commit
2737     #     1. Make a new working tree with the same object
2738     #        store as our main tree and check out the main
2739     #        tree's HEAD.
2740     #     2. Copy .pc from the fake's extraction, if necessary
2741     #     3. Run dpkg-source --commit
2742     #     4. If the result has changes to debian/, then
2743     #          - git-add them them
2744     #          - git-add .pc if we had a .pc in-tree
2745     #          - git-commit
2746     #     5. If we had a .pc in-tree, delete it, and git-commit
2747     #     6. Back in the main tree, fast forward to the new HEAD
2748
2749     my $clogp = parsechangelog();
2750     my $headref = git_rev_parse('HEAD');
2751
2752     prep_ud();
2753     changedir $ud;
2754
2755     my $upstreamversion=$version;
2756     $upstreamversion =~ s/-[^-]*$//;
2757
2758     my $fakeversion="$upstreamversion-~~DGITFAKE";
2759
2760     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2761     print $fakedsc <<END or die $!;
2762 Format: 3.0 (quilt)
2763 Source: $package
2764 Version: $fakeversion
2765 Files:
2766 END
2767
2768     my $dscaddfile=sub {
2769         my ($b) = @_;
2770
2771         my $md = new Digest::MD5;
2772
2773         my $fh = new IO::File $b, '<' or die "$b $!";
2774         stat $fh or die $!;
2775         my $size = -s _;
2776
2777         $md->addfile($fh);
2778         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2779     };
2780
2781     foreach my $f (<../../../../*>) { #/){
2782         my $b=$f; $b =~ s{.*/}{};
2783         next unless is_orig_file $b, srcfn $upstreamversion,'';
2784         link $f, $b or die "$b $!";
2785         $dscaddfile->($b);
2786     }
2787
2788     my @files=qw(debian/source/format debian/rules);
2789     if (stat_exists '../../../debian/patches') {
2790         push @files, 'debian/patches';
2791     }
2792
2793     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2794     runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2795
2796     $dscaddfile->($debtar);
2797     close $fakedsc or die $!;
2798
2799     runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2800
2801     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2802     rename $fakexdir, "fake" or die "$fakexdir $!";
2803
2804     mkdir "work" or die $!;
2805     changedir "work";
2806     mktree_in_ud_here();
2807     runcmd @git, qw(reset --hard), $headref;
2808
2809     my $mustdeletepc=0;
2810     if (stat_exists ".pc") {
2811         -d _ or die;
2812         progress "Tree already contains .pc - will use it then delete it.";
2813         $mustdeletepc=1;
2814     } else {
2815         rename '../fake/.pc','.pc' or die $!;
2816     }
2817
2818     quiltify($clogp,$headref);
2819
2820     if (!open P, '>>', ".pc/applied-patches") {
2821         $!==&ENOENT or die $!;
2822     } else {
2823         close P;
2824     }
2825
2826     commit_quilty_patch();
2827
2828     if ($mustdeletepc) {
2829         runcmd @git, qw(rm -rqf .pc);
2830         commit_admin "Commit removal of .pc (quilt series tracking data)";
2831     }
2832
2833     changedir '../../../..';
2834     runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2835 }
2836
2837 sub quilt_fixup_editor () {
2838     my $descfn = $ENV{$fakeeditorenv};
2839     my $editing = $ARGV[$#ARGV];
2840     open I1, '<', $descfn or die "$descfn: $!";
2841     open I2, '<', $editing or die "$editing: $!";
2842     unlink $editing or die "$editing: $!";
2843     open O, '>', $editing or die "$editing: $!";
2844     while (<I1>) { print O or die $!; } I1->error and die $!;
2845     my $copying = 0;
2846     while (<I2>) {
2847         $copying ||= m/^\-\-\- /;
2848         next unless $copying;
2849         print O or die $!;
2850     }
2851     I2->error and die $!;
2852     close O or die $1;
2853     exit 0;
2854 }
2855
2856 #----- other building -----
2857
2858 sub clean_tree () {
2859     if ($cleanmode eq 'dpkg-source') {
2860         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2861     } elsif ($cleanmode eq 'dpkg-source-d') {
2862         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2863     } elsif ($cleanmode eq 'git') {
2864         runcmd_ordryrun_local @git, qw(clean -xdf);
2865     } elsif ($cleanmode eq 'git-ff') {
2866         runcmd_ordryrun_local @git, qw(clean -xdff);
2867     } elsif ($cleanmode eq 'check') {
2868         my $leftovers = cmdoutput @git, qw(clean -xdn);
2869         if (length $leftovers) {
2870             print STDERR $leftovers, "\n" or die $!;
2871             fail "tree contains uncommitted files and --clean=check specified";
2872         }
2873     } elsif ($cleanmode eq 'none') {
2874     } else {
2875         die "$cleanmode ?";
2876     }
2877 }
2878
2879 sub cmd_clean () {
2880     badusage "clean takes no additional arguments" if @ARGV;
2881     notpushing();
2882     clean_tree();
2883 }
2884
2885 sub build_prep () {
2886     notpushing();
2887     badusage "-p is not allowed when building" if defined $package;
2888     check_not_dirty();
2889     clean_tree();
2890     my $clogp = parsechangelog();
2891     $isuite = getfield $clogp, 'Distribution';
2892     $package = getfield $clogp, 'Source';
2893     $version = getfield $clogp, 'Version';
2894     build_maybe_quilt_fixup();
2895 }
2896
2897 sub changesopts () {
2898     my @opts =@changesopts[1..$#changesopts];
2899     if (!defined $changes_since_version) {
2900         my @vsns = archive_query('archive_query');
2901         my @quirk = access_quirk();
2902         if ($quirk[0] eq 'backports') {
2903             local $isuite = $quirk[2];
2904             local $csuite;
2905             canonicalise_suite();
2906             push @vsns, archive_query('archive_query');
2907         }
2908         if (@vsns) {
2909             @vsns = map { $_->[0] } @vsns;
2910             @vsns = sort { -version_compare($a, $b) } @vsns;
2911             $changes_since_version = $vsns[0];
2912             progress "changelog will contain changes since $vsns[0]";
2913         } else {
2914             $changes_since_version = '_';
2915             progress "package seems new, not specifying -v<version>";
2916         }
2917     }
2918     if ($changes_since_version ne '_') {
2919         unshift @opts, "-v$changes_since_version";
2920     }
2921     return @opts;
2922 }
2923
2924 sub massage_dbp_args ($) {
2925     my ($cmd) = @_;
2926     return unless $cleanmode =~ m/git|none/;
2927     debugcmd '#massaging#', @$cmd if $debuglevel>1;
2928     my @newcmd = shift @$cmd;
2929     # -nc has the side effect of specifying -b if nothing else specified
2930     push @newcmd, '-nc';
2931     # and some combinations of -S, -b, et al, are errors, rather than
2932     # later simply overriding earlier
2933     push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2934     push @newcmd, @$cmd;
2935     @$cmd = @newcmd;
2936 }
2937
2938 sub cmd_build {
2939     build_prep();
2940     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2941     massage_dbp_args \@dbp;
2942     runcmd_ordryrun_local @dbp;
2943     printdone "build successful\n";
2944 }
2945
2946 sub cmd_git_build {
2947     build_prep();
2948     my @dbp = @dpkgbuildpackage;
2949     massage_dbp_args \@dbp;
2950     my @cmd =
2951         (qw(git-buildpackage -us -uc --git-no-sign-tags),
2952          "--git-builder=@dbp");
2953     unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2954         canonicalise_suite();
2955         push @cmd, "--git-debian-branch=".lbranch();
2956     }
2957     push @cmd, changesopts();
2958     runcmd_ordryrun_local @cmd, @ARGV;
2959     printdone "build successful\n";
2960 }
2961
2962 sub build_source {
2963     build_prep();
2964     $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2965     $dscfn = dscfn($version);
2966     if ($cleanmode eq 'dpkg-source') {
2967         runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2968             changesopts();
2969     } elsif ($cleanmode eq 'dpkg-source-d') {
2970         runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2971             changesopts();
2972     } else {
2973         my $pwd = must_getcwd();
2974         my $leafdir = basename $pwd;
2975         changedir "..";
2976         runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2977         changedir $pwd;
2978         runcmd_ordryrun_local qw(sh -ec),
2979             'exec >$1; shift; exec "$@"','x',
2980             "../$sourcechanges",
2981             @dpkggenchanges, qw(-S), changesopts();
2982     }
2983 }
2984
2985 sub cmd_build_source {
2986     badusage "build-source takes no additional arguments" if @ARGV;
2987     build_source();
2988     printdone "source built, results in $dscfn and $sourcechanges";
2989 }
2990
2991 sub cmd_sbuild {
2992     build_source();
2993     changedir "..";
2994     my $pat = "${package}_".(stripepoch $version)."_*.changes";
2995     if (act_local()) {
2996         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2997         stat_exists $sourcechanges
2998             or fail "$sourcechanges (in parent directory): $!";
2999         foreach my $cf (glob $pat) {
3000             next if $cf eq $sourcechanges;
3001             unlink $cf or fail "remove $cf: $!";
3002         }
3003     }
3004     runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
3005     my @changesfiles = glob $pat;
3006     @changesfiles = sort {
3007         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3008             or $a cmp $b
3009     } @changesfiles;
3010     fail "wrong number of different changes files (@changesfiles)"
3011         unless @changesfiles;
3012     runcmd_ordryrun_local @mergechanges, @changesfiles;
3013     my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
3014     if (act_local()) {
3015         stat_exists $multichanges or fail "$multichanges: $!";
3016     }
3017     printdone "build successful, results in $multichanges\n" or die $!;
3018 }
3019
3020 sub cmd_quilt_fixup {
3021     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3022     my $clogp = parsechangelog();
3023     $version = getfield $clogp, 'Version';
3024     $package = getfield $clogp, 'Source';
3025     build_maybe_quilt_fixup();
3026 }
3027
3028 sub cmd_archive_api_query {
3029     badusage "need only 1 subpath argument" unless @ARGV==1;
3030     my ($subpath) = @ARGV;
3031     my @cmd = archive_api_query_cmd($subpath);
3032     debugcmd ">",@cmd;
3033     exec @cmd or fail "exec curl: $!\n";
3034 }
3035
3036 sub cmd_clone_dgit_repos_server {
3037     badusage "need destination argument" unless @ARGV==1;
3038     my ($destdir) = @ARGV;
3039     $package = '_dgit-repos-server';
3040     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3041     debugcmd ">",@cmd;
3042     exec @cmd or fail "exec git clone: $!\n";
3043 }
3044
3045 sub cmd_setup_mergechangelogs {
3046     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3047     setup_mergechangelogs(1);
3048 }
3049
3050 sub cmd_setup_useremail {
3051     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3052     setup_useremail(1);
3053 }
3054
3055 sub cmd_setup_new_tree {
3056     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3057     setup_new_tree();
3058 }
3059
3060 #---------- argument parsing and main program ----------
3061
3062 sub cmd_version {
3063     print "dgit version $our_version\n" or die $!;
3064     exit 0;
3065 }
3066
3067 sub parseopts () {
3068     my $om;
3069
3070     if (defined $ENV{'DGIT_SSH'}) {
3071         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3072     } elsif (defined $ENV{'GIT_SSH'}) {
3073         @ssh = ($ENV{'GIT_SSH'});
3074     }
3075
3076     while (@ARGV) {
3077         last unless $ARGV[0] =~ m/^-/;
3078         $_ = shift @ARGV;
3079         last if m/^--?$/;
3080         if (m/^--/) {
3081             if (m/^--dry-run$/) {
3082                 push @ropts, $_;
3083                 $dryrun_level=2;
3084             } elsif (m/^--damp-run$/) {
3085                 push @ropts, $_;
3086                 $dryrun_level=1;
3087             } elsif (m/^--no-sign$/) {
3088                 push @ropts, $_;
3089                 $sign=0;
3090             } elsif (m/^--help$/) {
3091                 cmd_help();
3092             } elsif (m/^--version$/) {
3093                 cmd_version();
3094             } elsif (m/^--new$/) {
3095                 push @ropts, $_;
3096                 $new_package=1;
3097             } elsif (m/^--since-version=([^_]+|_)$/) {
3098                 push @ropts, $_;
3099                 $changes_since_version = $1;
3100             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3101                      ($om = $opts_opt_map{$1}) &&
3102                      length $om->[0]) {
3103                 push @ropts, $_;
3104                 $om->[0] = $2;
3105             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3106                      !$opts_opt_cmdonly{$1} &&
3107                      ($om = $opts_opt_map{$1})) {
3108                 push @ropts, $_;
3109                 push @$om, $2;
3110             } elsif (m/^--existing-package=(.*)/s) {
3111                 push @ropts, $_;
3112                 $existing_package = $1;
3113             } elsif (m/^--initiator-tempdir=(.*)/s) {
3114                 $initiator_tempdir = $1;
3115                 $initiator_tempdir =~ m#^/# or
3116                     badusage "--initiator-tempdir must be used specify an".
3117                         " absolute, not relative, directory."
3118             } elsif (m/^--distro=(.*)/s) {
3119                 push @ropts, $_;
3120                 $idistro = $1;
3121             } elsif (m/^--build-products-dir=(.*)/s) {
3122                 push @ropts, $_;
3123                 $buildproductsdir = $1;
3124             } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
3125                 push @ropts, $_;
3126                 $cleanmode = $1;
3127             } elsif (m/^--clean=(.*)$/s) {
3128                 badusage "unknown cleaning mode \`$1'";
3129             } elsif (m/^--quilt=($quilt_modes_re)$/s) {
3130                 push @ropts, $_;
3131                 $quilt_mode = $1;
3132             } elsif (m/^--quilt=(.*)$/s) {
3133                 badusage "unknown quilt fixup mode \`$1'";
3134             } elsif (m/^--ignore-dirty$/s) {
3135                 push @ropts, $_;
3136                 $ignoredirty = 1;
3137             } elsif (m/^--no-quilt-fixup$/s) {
3138                 push @ropts, $_;
3139                 $quilt_mode = 'nocheck';
3140             } elsif (m/^--no-rm-on-error$/s) {
3141                 push @ropts, $_;
3142                 $rmonerror = 0;
3143             } elsif (m/^--deliberately-($deliberately_re)$/s) {
3144                 push @ropts, $_;
3145                 push @deliberatelies, $&;
3146             } else {
3147                 badusage "unknown long option \`$_'";
3148             }
3149         } else {
3150             while (m/^-./s) {
3151                 if (s/^-n/-/) {
3152                     push @ropts, $&;
3153                     $dryrun_level=2;
3154                 } elsif (s/^-L/-/) {
3155                     push @ropts, $&;
3156                     $dryrun_level=1;
3157                 } elsif (s/^-h/-/) {
3158                     cmd_help();
3159                 } elsif (s/^-D/-/) {
3160                     push @ropts, $&;
3161                     $debuglevel++;
3162                     enabledebug();
3163                 } elsif (s/^-N/-/) {
3164                     push @ropts, $&;
3165                     $new_package=1;
3166                 } elsif (s/^-v([^_]+|_)$//s) {
3167                     push @ropts, $&;
3168                     $changes_since_version = $1;
3169                 } elsif (m/^-m/) {
3170                     push @ropts, $&;
3171                     push @changesopts, $_;
3172                     $_ = '';
3173                 } elsif (s/^-c(.*=.*)//s) {
3174                     push @ropts, $&;
3175                     push @git, '-c', $1;
3176                 } elsif (s/^-d(.+)//s) {
3177                     push @ropts, $&;
3178                     $idistro = $1;
3179                 } elsif (s/^-C(.+)//s) {
3180                     push @ropts, $&;
3181                     $changesfile = $1;
3182                     if ($changesfile =~ s#^(.*)/##) {
3183                         $buildproductsdir = $1;
3184                     }
3185                 } elsif (s/^-k(.+)//s) {
3186                     $keyid=$1;
3187                 } elsif (m/^-[vdCk]$/) {
3188                     badusage
3189  "option \`$_' requires an argument (and no space before the argument)";
3190                 } elsif (s/^-wn$//s) {
3191                     push @ropts, $&;
3192                     $cleanmode = 'none';
3193                 } elsif (s/^-wg$//s) {
3194                     push @ropts, $&;
3195                     $cleanmode = 'git';
3196                 } elsif (s/^-wgf$//s) {
3197                     push @ropts, $&;
3198                     $cleanmode = 'git-ff';
3199                 } elsif (s/^-wd$//s) {
3200                     push @ropts, $&;
3201                     $cleanmode = 'dpkg-source';
3202                 } elsif (s/^-wdd$//s) {
3203                     push @ropts, $&;
3204                     $cleanmode = 'dpkg-source-d';
3205                 } elsif (s/^-wc$//s) {
3206                     push @ropts, $&;
3207                     $cleanmode = 'check';
3208                 } else {
3209                     badusage "unknown short option \`$_'";
3210                 }
3211             }
3212         }
3213     }
3214 }
3215
3216 sub finalise_opts_opts () {
3217     foreach my $k (keys %opts_opt_map) {
3218         my $om = $opts_opt_map{$k};
3219
3220         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3221         if (defined $v) {
3222             badcfg "cannot set command for $k"
3223                 unless length $om->[0];
3224             $om->[0] = $v;
3225         }
3226
3227         foreach my $c (access_cfg_cfgs("opts-$k")) {
3228             my $vl = $gitcfg{$c};
3229             printdebug "CL $c ",
3230                 ($vl ? join " ", map { shellquote } @$vl : ""),
3231                 "\n" if $debuglevel >= 4;
3232             next unless $vl;
3233             badcfg "cannot configure options for $k"
3234                 if $opts_opt_cmdonly{$k};
3235             my $insertpos = $opts_cfg_insertpos{$k};
3236             @$om = ( @$om[0..$insertpos-1],
3237                      @$vl,
3238                      @$om[$insertpos..$#$om] );
3239         }
3240     }
3241 }
3242
3243 if ($ENV{$fakeeditorenv}) {
3244     git_slurp_config();
3245     quilt_fixup_editor();
3246 }
3247
3248 parseopts();
3249 git_slurp_config();
3250
3251 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3252 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3253     if $dryrun_level == 1;
3254 if (!@ARGV) {
3255     print STDERR $helpmsg or die $!;
3256     exit 8;
3257 }
3258 my $cmd = shift @ARGV;
3259 $cmd =~ y/-/_/;
3260
3261 if (!defined $quilt_mode) {
3262     local $access_forpush;
3263     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3264         // access_cfg('quilt-mode', 'RETURN-UNDEF')
3265         // 'linear';
3266     $quilt_mode =~ m/^($quilt_modes_re)$/
3267         or badcfg "unknown quilt-mode \`$quilt_mode'";
3268     $quilt_mode = $1;
3269 }
3270
3271 my $fn = ${*::}{"cmd_$cmd"};
3272 $fn or badusage "unknown operation $cmd";
3273 $fn->();