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, access_basedistro);
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     } else {
1901         canonicalise_suite();
1902     }
1903     if (defined $specsuite &&
1904         $specsuite ne $isuite &&
1905         $specsuite ne $csuite) {
1906             fail "dgit push: changelog specifies $isuite ($csuite)".
1907                 " but command line specifies $specsuite";
1908     }
1909     if (check_for_git()) {
1910         git_fetch_us();
1911     }
1912     my $forceflag = '';
1913     if (fetch_from_archive()) {
1914         if (is_fast_fwd(lrref(), 'HEAD')) {
1915             # ok
1916         } elsif (deliberately_not_fast_forward) {
1917             $forceflag = '+';
1918         } else {
1919             fail "dgit push: HEAD is not a descendant".
1920                 " of the archive's version.\n".
1921                 "dgit: To overwrite its contents,".
1922                 " use git merge -s ours ".lrref().".\n".
1923                 "dgit: To rewind history, if permitted by the archive,".
1924                 " use --deliberately-not-fast-forward";
1925         }
1926     } else {
1927         $new_package or
1928             fail "package appears to be new in this suite;".
1929                 " if this is intentional, use --new";
1930     }
1931     dopush($forceflag);
1932 }
1933
1934 #---------- remote commands' implementation ----------
1935
1936 sub cmd_remote_push_build_host {
1937     my ($nrargs) = shift @ARGV;
1938     my (@rargs) = @ARGV[0..$nrargs-1];
1939     @ARGV = @ARGV[$nrargs..$#ARGV];
1940     die unless @rargs;
1941     my ($dir,$vsnwant) = @rargs;
1942     # vsnwant is a comma-separated list; we report which we have
1943     # chosen in our ready response (so other end can tell if they
1944     # offered several)
1945     $debugprefix = ' ';
1946     $we_are_responder = 1;
1947     $us .= " (build host)";
1948
1949     open PI, "<&STDIN" or die $!;
1950     open STDIN, "/dev/null" or die $!;
1951     open PO, ">&STDOUT" or die $!;
1952     autoflush PO 1;
1953     open STDOUT, ">&STDERR" or die $!;
1954     autoflush STDOUT 1;
1955
1956     $vsnwant //= 1;
1957     fail "build host has dgit rpush protocol version".
1958         " $rpushprotovsn but invocation host has $vsnwant"
1959         unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
1960
1961     responder_send_command("dgit-remote-push-ready $rpushprotovsn");
1962
1963     changedir $dir;
1964     &cmd_push;
1965 }
1966
1967 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
1968 # ... for compatibility with proto vsn.1 dgit (just so that user gets
1969 #     a good error message)
1970
1971 our $i_tmp;
1972
1973 sub i_cleanup {
1974     local ($@, $?);
1975     my $report = i_child_report();
1976     if (defined $report) {
1977         printdebug "($report)\n";
1978     } elsif ($i_child_pid) {
1979         printdebug "(killing build host child $i_child_pid)\n";
1980         kill 15, $i_child_pid;
1981     }
1982     if (defined $i_tmp && !defined $initiator_tempdir) {
1983         changedir "/";
1984         eval { rmtree $i_tmp; };
1985     }
1986 }
1987
1988 END { i_cleanup(); }
1989
1990 sub i_method {
1991     my ($base,$selector,@args) = @_;
1992     $selector =~ s/\-/_/g;
1993     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
1994 }
1995
1996 sub cmd_rpush {
1997     my $host = nextarg;
1998     my $dir;
1999     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2000         $host = $1;
2001         $dir = $'; #';
2002     } else {
2003         $dir = nextarg;
2004     }
2005     $dir =~ s{^-}{./-};
2006     my @rargs = ($dir,$rpushprotovsn);
2007     my @rdgit;
2008     push @rdgit, @dgit;
2009     push @rdgit, @ropts;
2010     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2011     push @rdgit, @ARGV;
2012     my @cmd = (@ssh, $host, shellquote @rdgit);
2013     debugcmd "+",@cmd;
2014
2015     if (defined $initiator_tempdir) {
2016         rmtree $initiator_tempdir;
2017         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2018         $i_tmp = $initiator_tempdir;
2019     } else {
2020         $i_tmp = tempdir();
2021     }
2022     $i_child_pid = open2(\*RO, \*RI, @cmd);
2023     changedir $i_tmp;
2024     initiator_expect { m/^dgit-remote-push-ready/ };
2025     for (;;) {
2026         my ($icmd,$iargs) = initiator_expect {
2027             m/^(\S+)(?: (.*))?$/;
2028             ($1,$2);
2029         };
2030         i_method "i_resp", $icmd, $iargs;
2031     }
2032 }
2033
2034 sub i_resp_progress ($) {
2035     my ($rhs) = @_;
2036     my $msg = protocol_read_bytes \*RO, $rhs;
2037     progress $msg;
2038 }
2039
2040 sub i_resp_complete {
2041     my $pid = $i_child_pid;
2042     $i_child_pid = undef; # prevents killing some other process with same pid
2043     printdebug "waiting for build host child $pid...\n";
2044     my $got = waitpid $pid, 0;
2045     die $! unless $got == $pid;
2046     die "build host child failed $?" if $?;
2047
2048     i_cleanup();
2049     printdebug "all done\n";
2050     exit 0;
2051 }
2052
2053 sub i_resp_file ($) {
2054     my ($keyword) = @_;
2055     my $localname = i_method "i_localname", $keyword;
2056     my $localpath = "$i_tmp/$localname";
2057     stat_exists $localpath and
2058         badproto \*RO, "file $keyword ($localpath) twice";
2059     protocol_receive_file \*RO, $localpath;
2060     i_method "i_file", $keyword;
2061 }
2062
2063 our %i_param;
2064
2065 sub i_resp_param ($) {
2066     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2067     $i_param{$1} = $2;
2068 }
2069
2070 sub i_resp_previously ($) {
2071     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2072         or badproto \*RO, "bad previously spec";
2073     my $r = system qw(git check-ref-format), $1;
2074     die "bad previously ref spec ($r)" if $r;
2075     $previously{$1} = $2;
2076 }
2077
2078 our %i_wanted;
2079
2080 sub i_resp_want ($) {
2081     my ($keyword) = @_;
2082     die "$keyword ?" if $i_wanted{$keyword}++;
2083     my @localpaths = i_method "i_want", $keyword;
2084     printdebug "[[  $keyword @localpaths\n";
2085     foreach my $localpath (@localpaths) {
2086         protocol_send_file \*RI, $localpath;
2087     }
2088     print RI "files-end\n" or die $!;
2089 }
2090
2091 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2092
2093 sub i_localname_parsed_changelog {
2094     return "remote-changelog.822";
2095 }
2096 sub i_file_parsed_changelog {
2097     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2098         push_parse_changelog "$i_tmp/remote-changelog.822";
2099     die if $i_dscfn =~ m#/|^\W#;
2100 }
2101
2102 sub i_localname_dsc {
2103     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2104     return $i_dscfn;
2105 }
2106 sub i_file_dsc { }
2107
2108 sub i_localname_changes {
2109     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2110     $i_changesfn = $i_dscfn;
2111     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2112     return $i_changesfn;
2113 }
2114 sub i_file_changes { }
2115
2116 sub i_want_signed_tag {
2117     printdebug Dumper(\%i_param, $i_dscfn);
2118     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2119         && defined $i_param{'csuite'}
2120         or badproto \*RO, "premature desire for signed-tag";
2121     my $head = $i_param{'head'};
2122     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2123
2124     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2125     $csuite = $&;
2126     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2127
2128     my $tagobjfn =
2129         push_mktag $head, $i_clogp, $i_tag,
2130             $i_dscfn,
2131             $i_changesfn, 'remote changes',
2132             sub { "tag$_[0]"; };
2133
2134     return $tagobjfn;
2135 }
2136
2137 sub i_want_signed_dsc_changes {
2138     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2139     sign_changes $i_changesfn;
2140     return ($i_dscfn, $i_changesfn);
2141 }
2142
2143 #---------- building etc. ----------
2144
2145 our $version;
2146 our $sourcechanges;
2147 our $dscfn;
2148
2149 #----- `3.0 (quilt)' handling -----
2150
2151 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2152
2153 sub quiltify_dpkg_commit ($$$;$) {
2154     my ($patchname,$author,$msg, $xinfo) = @_;
2155     $xinfo //= '';
2156
2157     mkpath '.git/dgit';
2158     my $descfn = ".git/dgit/quilt-description.tmp";
2159     open O, '>', $descfn or die "$descfn: $!";
2160     $msg =~ s/\s+$//g;
2161     $msg =~ s/\n/\n /g;
2162     $msg =~ s/^\s+$/ ./mg;
2163     print O <<END or die $!;
2164 Description: $msg
2165 Author: $author
2166 $xinfo
2167 ---
2168
2169 END
2170     close O or die $!;
2171
2172     {
2173         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2174         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2175         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2176         runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2177     }
2178 }
2179
2180 sub quiltify_trees_differ ($$) {
2181     my ($x,$y) = @_;
2182     # returns 1 iff the two tree objects differ other than in debian/
2183     local $/=undef;
2184     my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2185     my $diffs= cmdoutput @cmd;
2186     foreach my $f (split /\0/, $diffs) {
2187         next if $f eq 'debian';
2188         return 1;
2189     }
2190     return 0;
2191 }
2192
2193 sub quiltify_tree_sentinelfiles ($) {
2194     # lists the `sentinel' files present in the tree
2195     my ($x) = @_;
2196     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2197         qw(-- debian/rules debian/control);
2198     $r =~ s/\n/,/g;
2199     return $r;
2200 }
2201
2202 sub quiltify ($$) {
2203     my ($clogp,$target) = @_;
2204
2205     # Quilt patchification algorithm
2206     #
2207     # We search backwards through the history of the main tree's HEAD
2208     # (T) looking for a start commit S whose tree object is identical
2209     # to to the patch tip tree (ie the tree corresponding to the
2210     # current dpkg-committed patch series).  For these purposes
2211     # `identical' disregards anything in debian/ - this wrinkle is
2212     # necessary because dpkg-source treates debian/ specially.
2213     #
2214     # We can only traverse edges where at most one of the ancestors'
2215     # trees differs (in changes outside in debian/).  And we cannot
2216     # handle edges which change .pc/ or debian/patches.  To avoid
2217     # going down a rathole we avoid traversing edges which introduce
2218     # debian/rules or debian/control.  And we set a limit on the
2219     # number of edges we are willing to look at.
2220     #
2221     # If we succeed, we walk forwards again.  For each traversed edge
2222     # PC (with P parent, C child) (starting with P=S and ending with
2223     # C=T) to we do this:
2224     #  - git checkout C
2225     #  - dpkg-source --commit with a patch name and message derived from C
2226     # After traversing PT, we git commit the changes which
2227     # should be contained within debian/patches.
2228
2229     changedir '../fake';
2230     mktree_in_ud_here();
2231     rmtree '.pc';
2232     runcmd @git, 'add', '.';
2233     my $oldtiptree=git_write_tree();
2234     changedir '../work';
2235
2236     # The search for the path S..T is breadth-first.  We maintain a
2237     # todo list containing search nodes.  A search node identifies a
2238     # commit, and looks something like this:
2239     #  $p = {
2240     #      Commit => $git_commit_id,
2241     #      Child => $c,                          # or undef if P=T
2242     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2243     #      Nontrivial => true iff $p..$c has relevant changes
2244     #  };
2245
2246     my @todo;
2247     my @nots;
2248     my $sref_S;
2249     my $max_work=100;
2250     my %considered; # saves being exponential on some weird graphs
2251
2252     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2253
2254     my $not = sub {
2255         my ($search,$whynot) = @_;
2256         printdebug " search NOT $search->{Commit} $whynot\n";
2257         $search->{Whynot} = $whynot;
2258         push @nots, $search;
2259         no warnings qw(exiting);
2260         next;
2261     };
2262
2263     push @todo, {
2264         Commit => $target,
2265     };
2266
2267     while (@todo) {
2268         my $c = shift @todo;
2269         next if $considered{$c->{Commit}}++;
2270
2271         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2272
2273         printdebug "quiltify investigate $c->{Commit}\n";
2274
2275         # are we done?
2276         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2277             printdebug " search finished hooray!\n";
2278             $sref_S = $c;
2279             last;
2280         }
2281
2282         if ($quilt_mode eq 'nofix') {
2283             fail "quilt fixup required but quilt mode is \`nofix'\n".
2284                 "HEAD commit $c->{Commit} differs from tree implied by ".
2285                 " debian/patches (tree object $oldtiptree)";
2286         }
2287         if ($quilt_mode eq 'smash') {
2288             printdebug " search quitting smash\n";
2289             last;
2290         }
2291
2292         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2293         $not->($c, "has $c_sentinels not $t_sentinels")
2294             if $c_sentinels ne $t_sentinels;
2295
2296         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2297         $commitdata =~ m/\n\n/;
2298         $commitdata =~ $`;
2299         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2300         @parents = map { { Commit => $_, Child => $c } } @parents;
2301
2302         $not->($c, "root commit") if !@parents;
2303
2304         foreach my $p (@parents) {
2305             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2306         }
2307         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2308         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2309
2310         foreach my $p (@parents) {
2311             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2312
2313             my @cmd= (@git, qw(diff-tree -r --name-only),
2314                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2315             my $patchstackchange = cmdoutput @cmd;
2316             if (length $patchstackchange) {
2317                 $patchstackchange =~ s/\n/,/g;
2318                 $not->($p, "changed $patchstackchange");
2319             }
2320
2321             printdebug " search queue P=$p->{Commit} ",
2322                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2323             push @todo, $p;
2324         }
2325     }
2326
2327     if (!$sref_S) {
2328         printdebug "quiltify want to smash\n";
2329
2330         my $abbrev = sub {
2331             my $x = $_[0]{Commit};
2332             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2333             return $;
2334         };
2335         my $reportnot = sub {
2336             my ($notp) = @_;
2337             my $s = $abbrev->($notp);
2338             my $c = $notp->{Child};
2339             $s .= "..".$abbrev->($c) if $c;
2340             $s .= ": ".$notp->{Whynot};
2341             return $s;
2342         };
2343         if ($quilt_mode eq 'linear') {
2344             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2345             foreach my $notp (@nots) {
2346                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2347             }
2348             fail "quilt fixup naive history linearisation failed.\n".
2349  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2350         } elsif ($quilt_mode eq 'smash') {
2351         } elsif ($quilt_mode eq 'auto') {
2352             progress "quilt fixup cannot be linear, smashing...";
2353         } else {
2354             die "$quilt_mode ?";
2355         }
2356
2357         my $time = time;
2358         my $ncommits = 3;
2359         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2360
2361         quiltify_dpkg_commit "auto-$version-$target-$time",
2362             (getfield $clogp, 'Maintainer'),
2363             "Automatically generated patch ($clogp->{Version})\n".
2364             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2365         return;
2366     }
2367
2368     progress "quiltify linearisation planning successful, executing...";
2369
2370     for (my $p = $sref_S;
2371          my $c = $p->{Child};
2372          $p = $p->{Child}) {
2373         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2374         next unless $p->{Nontrivial};
2375
2376         my $cc = $c->{Commit};
2377
2378         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2379         $commitdata =~ m/\n\n/ or die "$c ?";
2380         $commitdata = $`;
2381         my $msg = $'; #';
2382         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2383         my $author = $1;
2384
2385         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2386
2387         my $title = $1;
2388         my $patchname = $title;
2389         $patchname =~ s/[.:]$//;
2390         $patchname =~ y/ A-Z/-a-z/;
2391         $patchname =~ y/-a-z0-9_.+=~//cd;
2392         $patchname =~ s/^\W/x-$&/;
2393         $patchname = substr($patchname,0,40);
2394         my $index;
2395         for ($index='';
2396              stat "debian/patches/$patchname$index";
2397              $index++) { }
2398         $!==ENOENT or die "$patchname$index $!";
2399
2400         runcmd @git, qw(checkout -q), $cc;
2401
2402         # We use the tip's changelog so that dpkg-source doesn't
2403         # produce complaining messages from dpkg-parsechangelog.  None
2404         # of the information dpkg-source gets from the changelog is
2405         # actually relevant - it gets put into the original message
2406         # which dpkg-source provides our stunt editor, and then
2407         # overwritten.
2408         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2409
2410         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2411             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2412
2413         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2414     }
2415
2416     runcmd @git, qw(checkout -q master);
2417 }
2418
2419 sub build_maybe_quilt_fixup () {
2420     my $format=get_source_format;
2421     return unless madformat $format;
2422     # sigh
2423
2424     check_for_vendor_patches();
2425
2426     # Our objective is:
2427     #  - honour any existing .pc in case it has any strangeness
2428     #  - determine the git commit corresponding to the tip of
2429     #    the patch stack (if there is one)
2430     #  - if there is such a git commit, convert each subsequent
2431     #    git commit into a quilt patch with dpkg-source --commit
2432     #  - otherwise convert all the differences in the tree into
2433     #    a single git commit
2434     #
2435     # To do this we:
2436
2437     # Our git tree doesn't necessarily contain .pc.  (Some versions of
2438     # dgit would include the .pc in the git tree.)  If there isn't
2439     # one, we need to generate one by unpacking the patches that we
2440     # have.
2441     #
2442     # We first look for a .pc in the git tree.  If there is one, we
2443     # will use it.  (This is not the normal case.)
2444     #
2445     # Otherwise need to regenerate .pc so that dpkg-source --commit
2446     # can work.  We do this as follows:
2447     #     1. Collect all relevant .orig from parent directory
2448     #     2. Generate a debian.tar.gz out of
2449     #         debian/{patches,rules,source/format}
2450     #     3. Generate a fake .dsc containing just these fields:
2451     #          Format Source Version Files
2452     #     4. Extract the fake .dsc
2453     #        Now the fake .dsc has a .pc directory.
2454     # (In fact we do this in every case, because in future we will
2455     # want to search for a good base commit for generating patches.)
2456     #
2457     # Then we can actually do the dpkg-source --commit
2458     #     1. Make a new working tree with the same object
2459     #        store as our main tree and check out the main
2460     #        tree's HEAD.
2461     #     2. Copy .pc from the fake's extraction, if necessary
2462     #     3. Run dpkg-source --commit
2463     #     4. If the result has changes to debian/, then
2464     #          - git-add them them
2465     #          - git-add .pc if we had a .pc in-tree
2466     #          - git-commit
2467     #     5. If we had a .pc in-tree, delete it, and git-commit
2468     #     6. Back in the main tree, fast forward to the new HEAD
2469
2470     my $clogp = parsechangelog();
2471     my $headref = git_rev_parse('HEAD');
2472
2473     prep_ud();
2474     changedir $ud;
2475
2476     my $upstreamversion=$version;
2477     $upstreamversion =~ s/-[^-]*$//;
2478
2479     my $fakeversion="$upstreamversion-~~DGITFAKE";
2480
2481     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2482     print $fakedsc <<END or die $!;
2483 Format: 3.0 (quilt)
2484 Source: $package
2485 Version: $fakeversion
2486 Files:
2487 END
2488
2489     my $dscaddfile=sub {
2490         my ($b) = @_;
2491
2492         my $md = new Digest::MD5;
2493
2494         my $fh = new IO::File $b, '<' or die "$b $!";
2495         stat $fh or die $!;
2496         my $size = -s _;
2497
2498         $md->addfile($fh);
2499         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2500     };
2501
2502     foreach my $f (<../../../../*>) { #/){
2503         my $b=$f; $b =~ s{.*/}{};
2504         next unless is_orig_file $b, srcfn $upstreamversion,'';
2505         link $f, $b or die "$b $!";
2506         $dscaddfile->($b);
2507     }
2508
2509     my @files=qw(debian/source/format debian/rules);
2510     if (stat_exists '../../../debian/patches') {
2511         push @files, 'debian/patches';
2512     }
2513
2514     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2515     runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2516
2517     $dscaddfile->($debtar);
2518     close $fakedsc or die $!;
2519
2520     runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2521
2522     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2523     rename $fakexdir, "fake" or die "$fakexdir $!";
2524
2525     mkdir "work" or die $!;
2526     changedir "work";
2527     mktree_in_ud_here();
2528     runcmd @git, qw(reset --hard), $headref;
2529
2530     my $mustdeletepc=0;
2531     if (stat_exists ".pc") {
2532         -d _ or die;
2533         progress "Tree already contains .pc - will use it then delete it.";
2534         $mustdeletepc=1;
2535     } else {
2536         rename '../fake/.pc','.pc' or die $!;
2537     }
2538
2539     quiltify($clogp,$headref);
2540
2541     if (!open P, '>>', ".pc/applied-patches") {
2542         $!==&ENOENT or die $!;
2543     } else {
2544         close P;
2545     }
2546
2547     commit_quilty_patch();
2548
2549     if ($mustdeletepc) {
2550         runcmd @git, qw(rm -rqf .pc);
2551         commit_admin "Commit removal of .pc (quilt series tracking data)";
2552     }
2553
2554     changedir '../../../..';
2555     runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2556 }
2557
2558 sub quilt_fixup_editor () {
2559     my $descfn = $ENV{$fakeeditorenv};
2560     my $editing = $ARGV[$#ARGV];
2561     open I1, '<', $descfn or die "$descfn: $!";
2562     open I2, '<', $editing or die "$editing: $!";
2563     unlink $editing or die "$editing: $!";
2564     open O, '>', $editing or die "$editing: $!";
2565     while (<I1>) { print O or die $!; } I1->error and die $!;
2566     my $copying = 0;
2567     while (<I2>) {
2568         $copying ||= m/^\-\-\- /;
2569         next unless $copying;
2570         print O or die $!;
2571     }
2572     I2->error and die $!;
2573     close O or die $1;
2574     exit 0;
2575 }
2576
2577 #----- other building -----
2578
2579 sub clean_tree () {
2580     if ($cleanmode eq 'dpkg-source') {
2581         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2582     } elsif ($cleanmode eq 'git') {
2583         runcmd_ordryrun_local @git, qw(clean -xdf);
2584     } elsif ($cleanmode eq 'none') {
2585     } else {
2586         die "$cleanmode ?";
2587     }
2588 }
2589
2590 sub cmd_clean () {
2591     badusage "clean takes no additional arguments" if @ARGV;
2592     clean_tree();
2593 }
2594
2595 sub build_prep () {
2596     badusage "-p is not allowed when building" if defined $package;
2597     check_not_dirty();
2598     clean_tree();
2599     my $clogp = parsechangelog();
2600     $isuite = getfield $clogp, 'Distribution';
2601     $package = getfield $clogp, 'Source';
2602     $version = getfield $clogp, 'Version';
2603     build_maybe_quilt_fixup();
2604 }
2605
2606 sub changesopts () {
2607     my @opts =@changesopts[1..$#changesopts];
2608     if (!defined $changes_since_version) {
2609         my @vsns = archive_query('archive_query');
2610         my @quirk = access_quirk();
2611         if ($quirk[0] eq 'backports') {
2612             local $isuite = $quirk[2];
2613             local $csuite;
2614             canonicalise_suite();
2615             push @vsns, archive_query('archive_query');
2616         }
2617         if (@vsns) {
2618             @vsns = map { $_->[0] } @vsns;
2619             @vsns = sort { -version_compare($a, $b) } @vsns;
2620             $changes_since_version = $vsns[0];
2621             progress "changelog will contain changes since $vsns[0]";
2622         } else {
2623             $changes_since_version = '_';
2624             progress "package seems new, not specifying -v<version>";
2625         }
2626     }
2627     if ($changes_since_version ne '_') {
2628         unshift @opts, "-v$changes_since_version";
2629     }
2630     return @opts;
2631 }
2632
2633 sub massage_dbp_args ($) {
2634     my ($cmd) = @_;
2635     return unless $cleanmode =~ m/git|none/;
2636     debugcmd '#massaging#', @$cmd if $debuglevel>1;
2637     my @newcmd = shift @$cmd;
2638     # -nc has the side effect of specifying -b if nothing else specified
2639     push @newcmd, '-nc';
2640     # and some combinations of -S, -b, et al, are errors, rather than
2641     # later simply overriding earlier
2642     push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2643     push @newcmd, @$cmd;
2644     @$cmd = @newcmd;
2645 }
2646
2647 sub cmd_build {
2648     build_prep();
2649     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2650     massage_dbp_args \@dbp;
2651     runcmd_ordryrun_local @dbp;
2652     printdone "build successful\n";
2653 }
2654
2655 sub cmd_git_build {
2656     build_prep();
2657     my @dbp = @dpkgbuildpackage;
2658     massage_dbp_args \@dbp;
2659     my @cmd =
2660         (qw(git-buildpackage -us -uc --git-no-sign-tags),
2661          "--git-builder=@dbp");
2662     unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2663         canonicalise_suite();
2664         push @cmd, "--git-debian-branch=".lbranch();
2665     }
2666     push @cmd, changesopts();
2667     runcmd_ordryrun_local @cmd, @ARGV;
2668     printdone "build successful\n";
2669 }
2670
2671 sub build_source {
2672     build_prep();
2673     $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2674     $dscfn = dscfn($version);
2675     if ($cleanmode eq 'dpkg-source') {
2676         runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2677             changesopts();
2678     } else {
2679         my $pwd = must_getcwd();
2680         my $leafdir = basename $pwd;
2681         changedir "..";
2682         runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2683         changedir $pwd;
2684         runcmd_ordryrun_local qw(sh -ec),
2685             'exec >$1; shift; exec "$@"','x',
2686             "../$sourcechanges",
2687             @dpkggenchanges, qw(-S), changesopts();
2688     }
2689 }
2690
2691 sub cmd_build_source {
2692     badusage "build-source takes no additional arguments" if @ARGV;
2693     build_source();
2694     printdone "source built, results in $dscfn and $sourcechanges";
2695 }
2696
2697 sub cmd_sbuild {
2698     build_source();
2699     changedir "..";
2700     my $pat = "${package}_".(stripepoch $version)."_*.changes";
2701     if (act_local()) {
2702         stat_exist $dscfn or fail "$dscfn (in parent directory): $!";
2703         stat_exists $sourcechanges
2704             or fail "$sourcechanges (in parent directory): $!";
2705         foreach my $cf (glob $pat) {
2706             next if $cf eq $sourcechanges;
2707             unlink $cf or fail "remove $cf: $!";
2708         }
2709     }
2710     runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2711     my @changesfiles = glob $pat;
2712     @changesfiles = sort {
2713         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2714             or $a cmp $b
2715     } @changesfiles;
2716     fail "wrong number of different changes files (@changesfiles)"
2717         unless @changesfiles;
2718     runcmd_ordryrun_local @mergechanges, @changesfiles;
2719     my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2720     if (act_local()) {
2721         stat_exists $multichanges or fail "$multichanges: $!";
2722     }
2723     printdone "build successful, results in $multichanges\n" or die $!;
2724 }
2725
2726 sub cmd_quilt_fixup {
2727     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2728     my $clogp = parsechangelog();
2729     $version = getfield $clogp, 'Version';
2730     $package = getfield $clogp, 'Source';
2731     build_maybe_quilt_fixup();
2732 }
2733
2734 sub cmd_archive_api_query {
2735     badusage "need only 1 subpath argument" unless @ARGV==1;
2736     my ($subpath) = @ARGV;
2737     my @cmd = archive_api_query_cmd($subpath);
2738     debugcmd ">",@cmd;
2739     exec @cmd or fail "exec curl: $!\n";
2740 }
2741
2742 sub cmd_clone_dgit_repos_server {
2743     badusage "need destination argument" unless @ARGV==1;
2744     my ($destdir) = @ARGV;
2745     $package = '_dgit-repos-server';
2746     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2747     debugcmd ">",@cmd;
2748     exec @cmd or fail "exec git clone: $!\n";
2749 }
2750
2751 #---------- argument parsing and main program ----------
2752
2753 sub cmd_version {
2754     print "dgit version $our_version\n" or die $!;
2755     exit 0;
2756 }
2757
2758 sub parseopts () {
2759     my $om;
2760
2761     if (defined $ENV{'DGIT_SSH'}) {
2762         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2763     } elsif (defined $ENV{'GIT_SSH'}) {
2764         @ssh = ($ENV{'GIT_SSH'});
2765     }
2766
2767     while (@ARGV) {
2768         last unless $ARGV[0] =~ m/^-/;
2769         $_ = shift @ARGV;
2770         last if m/^--?$/;
2771         if (m/^--/) {
2772             if (m/^--dry-run$/) {
2773                 push @ropts, $_;
2774                 $dryrun_level=2;
2775             } elsif (m/^--damp-run$/) {
2776                 push @ropts, $_;
2777                 $dryrun_level=1;
2778             } elsif (m/^--no-sign$/) {
2779                 push @ropts, $_;
2780                 $sign=0;
2781             } elsif (m/^--help$/) {
2782                 cmd_help();
2783             } elsif (m/^--version$/) {
2784                 cmd_version();
2785             } elsif (m/^--new$/) {
2786                 push @ropts, $_;
2787                 $new_package=1;
2788             } elsif (m/^--since-version=([^_]+|_)$/) {
2789                 push @ropts, $_;
2790                 $changes_since_version = $1;
2791             } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2792                      ($om = $opts_opt_map{$1}) &&
2793                      length $om->[0]) {
2794                 push @ropts, $_;
2795                 $om->[0] = $2;
2796             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2797                      !$opts_opt_cmdonly{$1} &&
2798                      ($om = $opts_opt_map{$1})) {
2799                 push @ropts, $_;
2800                 push @$om, $2;
2801             } elsif (m/^--existing-package=(.*)/s) {
2802                 push @ropts, $_;
2803                 $existing_package = $1;
2804             } elsif (m/^--initiator-tempdir=(.*)/s) {
2805                 $initiator_tempdir = $1;
2806                 $initiator_tempdir =~ m#^/# or
2807                     badusage "--initiator-tempdir must be used specify an".
2808                         " absolute, not relative, directory."
2809             } elsif (m/^--distro=(.*)/s) {
2810                 push @ropts, $_;
2811                 $idistro = $1;
2812             } elsif (m/^--build-products-dir=(.*)/s) {
2813                 push @ropts, $_;
2814                 $buildproductsdir = $1;
2815             } elsif (m/^--clean=(dpkg-source|git|none)$/s) {
2816                 push @ropts, $_;
2817                 $cleanmode = $1;
2818             } elsif (m/^--clean=(.*)$/s) {
2819                 badusage "unknown cleaning mode \`$1'";
2820             } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2821                 push @ropts, $_;
2822                 $quilt_mode = $1;
2823             } elsif (m/^--quilt=(.*)$/s) {
2824                 badusage "unknown quilt fixup mode \`$1'";
2825             } elsif (m/^--ignore-dirty$/s) {
2826                 push @ropts, $_;
2827                 $ignoredirty = 1;
2828             } elsif (m/^--no-quilt-fixup$/s) {
2829                 push @ropts, $_;
2830                 $quilt_mode = 'nocheck';
2831             } elsif (m/^--no-rm-on-error$/s) {
2832                 push @ropts, $_;
2833                 $rmonerror = 0;
2834             } elsif (m/^--deliberately-($deliberately_re)$/s) {
2835                 push @ropts, $_;
2836                 push @deliberatelies, $&;
2837             } else {
2838                 badusage "unknown long option \`$_'";
2839             }
2840         } else {
2841             while (m/^-./s) {
2842                 if (s/^-n/-/) {
2843                     push @ropts, $&;
2844                     $dryrun_level=2;
2845                 } elsif (s/^-L/-/) {
2846                     push @ropts, $&;
2847                     $dryrun_level=1;
2848                 } elsif (s/^-h/-/) {
2849                     cmd_help();
2850                 } elsif (s/^-D/-/) {
2851                     push @ropts, $&;
2852                     $debuglevel++;
2853                     enabledebug();
2854                 } elsif (s/^-N/-/) {
2855                     push @ropts, $&;
2856                     $new_package=1;
2857                 } elsif (s/^-v([^_]+|_)$//s) {
2858                     push @ropts, $&;
2859                     $changes_since_version = $1;
2860                 } elsif (m/^-m/) {
2861                     push @ropts, $&;
2862                     push @changesopts, $_;
2863                     $_ = '';
2864                 } elsif (s/^-c(.*=.*)//s) {
2865                     push @ropts, $&;
2866                     push @git, '-c', $1;
2867                 } elsif (s/^-d(.+)//s) {
2868                     push @ropts, $&;
2869                     $idistro = $1;
2870                 } elsif (s/^-C(.+)//s) {
2871                     push @ropts, $&;
2872                     $changesfile = $1;
2873                     if ($changesfile =~ s#^(.*)/##) {
2874                         $buildproductsdir = $1;
2875                     }
2876                 } elsif (s/^-k(.+)//s) {
2877                     $keyid=$1;
2878                 } elsif (m/^-[vdCk]$/) {
2879                     badusage
2880  "option \`$_' requires an argument (and no space before the argument)";
2881                 } elsif (s/^-wn$//s) {
2882                     push @ropts, $&;
2883                     $cleanmode = 'none';
2884                 } elsif (s/^-wg$//s) {
2885                     push @ropts, $&;
2886                     $cleanmode = 'git';
2887                 } elsif (s/^-wd$//s) {
2888                     push @ropts, $&;
2889                     $cleanmode = 'dpkg-source';
2890                 } else {
2891                     badusage "unknown short option \`$_'";
2892                 }
2893             }
2894         }
2895     }
2896 }
2897
2898 if ($ENV{$fakeeditorenv}) {
2899     quilt_fixup_editor();
2900 }
2901
2902 parseopts();
2903 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
2904 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
2905     if $dryrun_level == 1;
2906 if (!@ARGV) {
2907     print STDERR $helpmsg or die $!;
2908     exit 8;
2909 }
2910 my $cmd = shift @ARGV;
2911 $cmd =~ y/-/_/;
2912
2913 if (!defined $quilt_mode) {
2914     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
2915         // access_cfg('quilt-mode', 'RETURN-UNDEF')
2916         // 'linear';
2917     $quilt_mode =~ m/^($quilt_modes_re)$/
2918         or badcfg "unknown quilt-mode \`$quilt_mode'";
2919     $quilt_mode = $1;
2920 }
2921
2922 my $fn = ${*::}{"cmd_$cmd"};
2923 $fn or badusage "unknown operation $cmd";
2924 $fn->();