dgit

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