dgit

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