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