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/$csuite"; }
 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     my @specs = (fetchspec());
1347     push @specs,
1348         map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1349         qw(tags heads);
1350     runcmd_ordryrun_local @git, qw(fetch -p -n), access_giturl(), @specs;
1351
1352     my %here;
1353     my $tagpat = debiantag('*',access_basedistro);
1354
1355     git_for_each_ref("refs/tags/".$tagpat, sub {
1356         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1357         printdebug "currently $fullrefname=$objid\n";
1358         $here{$fullrefname} = $objid;
1359     });
1360     git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1361         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1362         my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1363         printdebug "offered $lref=$objid\n";
1364         if (!defined $here{$lref}) {
1365             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1366             runcmd_ordryrun_local @upd;
1367         } elsif ($here{$lref} eq $objid) {
1368         } else {
1369             print STDERR \
1370                 "Not updateting $lref from $here{$lref} to $objid.\n";
1371         }
1372     });
1373 }
1374
1375 sub fetch_from_archive () {
1376     # ensures that lrref() is what is actually in the archive,
1377     #  one way or another
1378     get_archive_dsc();
1379
1380     if ($dsc) {
1381         foreach my $field (@ourdscfield) {
1382             $dsc_hash = $dsc->{$field};
1383             last if defined $dsc_hash;
1384         }
1385         if (defined $dsc_hash) {
1386             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1387             $dsc_hash = $&;
1388             progress "last upload to archive specified git hash";
1389         } else {
1390             progress "last upload to archive has NO git hash";
1391         }
1392     } else {
1393         progress "no version available from the archive";
1394     }
1395
1396     $lastpush_hash = git_get_ref(lrref());
1397     printdebug "previous reference hash=$lastpush_hash\n";
1398     my $hash;
1399     if (defined $dsc_hash) {
1400         fail "missing remote git history even though dsc has hash -".
1401             " could not find ref ".lrref().
1402             " (should have been fetched from ".access_giturl()."#".rrref().")"
1403             unless $lastpush_hash;
1404         $hash = $dsc_hash;
1405         ensure_we_have_orig();
1406         if ($dsc_hash eq $lastpush_hash) {
1407         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1408             print STDERR <<END or die $!;
1409
1410 Git commit in archive is behind the last version allegedly pushed/uploaded.
1411 Commit referred to by archive:  $dsc_hash
1412 Last allegedly pushed/uploaded: $lastpush_hash
1413 $later_warning_msg
1414 END
1415             $hash = $lastpush_hash;
1416         } else {
1417             fail "git head (".lrref()."=$lastpush_hash) is not a ".
1418                 "descendant of archive's .dsc hash ($dsc_hash)";
1419         }
1420     } elsif ($dsc) {
1421         $hash = generate_commit_from_dsc();
1422     } elsif ($lastpush_hash) {
1423         # only in git, not in the archive yet
1424         $hash = $lastpush_hash;
1425         print STDERR <<END or die $!;
1426
1427 Package not found in the archive, but has allegedly been pushed using dgit.
1428 $later_warning_msg
1429 END
1430     } else {
1431         printdebug "nothing found!\n";
1432         if (defined $skew_warning_vsn) {
1433             print STDERR <<END or die $!;
1434
1435 Warning: relevant archive skew detected.
1436 Archive allegedly contains $skew_warning_vsn
1437 But we were not able to obtain any version from the archive or git.
1438
1439 END
1440         }
1441         return 0;
1442     }
1443     printdebug "current hash=$hash\n";
1444     if ($lastpush_hash) {
1445         fail "not fast forward on last upload branch!".
1446             " (archive's version left in DGIT_ARCHIVE)"
1447             unless is_fast_fwd($lastpush_hash, $hash);
1448     }
1449     if (defined $skew_warning_vsn) {
1450         mkpath '.git/dgit';
1451         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1452         my $clogf = ".git/dgit/changelog.tmp";
1453         runcmd shell_cmd "exec >$clogf",
1454             @git, qw(cat-file blob), "$hash:debian/changelog";
1455         my $gotclogp = parsechangelog("-l$clogf");
1456         my $got_vsn = getfield $gotclogp, 'Version';
1457         printdebug "SKEW CHECK GOT $got_vsn\n";
1458         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1459             print STDERR <<END or die $!;
1460
1461 Warning: archive skew detected.  Using the available version:
1462 Archive allegedly contains    $skew_warning_vsn
1463 We were able to obtain only   $got_vsn
1464
1465 END
1466         }
1467     }
1468     if ($lastpush_hash ne $hash) {
1469         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1470         if (act_local()) {
1471             cmdoutput @upd_cmd;
1472         } else {
1473             dryrun_report @upd_cmd;
1474         }
1475     }
1476     return 1;
1477 }
1478
1479 sub clone ($) {
1480     my ($dstdir) = @_;
1481     canonicalise_suite();
1482     badusage "dry run makes no sense with clone" unless act_local();
1483     my $hasgit = check_for_git();
1484     mkdir $dstdir or die "$dstdir $!";
1485     changedir $dstdir;
1486     runcmd @git, qw(init -q);
1487     my $giturl = access_giturl(1);
1488     if (defined $giturl) {
1489         runcmd @git, qw(config), "remote.$remotename.fetch", fetchspec();
1490         open H, "> .git/HEAD" or die $!;
1491         print H "ref: ".lref()."\n" or die $!;
1492         close H or die $!;
1493         runcmd @git, qw(remote add), 'origin', $giturl;
1494     }
1495     if ($hasgit) {
1496         progress "fetching existing git history";
1497         git_fetch_us();
1498         runcmd_ordryrun_local @git, qw(fetch origin);
1499     } else {
1500         progress "starting new git history";
1501     }
1502     fetch_from_archive() or no_such_package;
1503     my $vcsgiturl = $dsc->{'Vcs-Git'};
1504     if (length $vcsgiturl) {
1505         $vcsgiturl =~ s/\s+-b\s+\S+//g;
1506         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1507     }
1508     runcmd @git, qw(reset --hard), lrref();
1509     printdone "ready for work in $dstdir";
1510 }
1511
1512 sub fetch () {
1513     if (check_for_git()) {
1514         git_fetch_us();
1515     }
1516     fetch_from_archive() or no_such_package();
1517     printdone "fetched into ".lrref();
1518 }
1519
1520 sub pull () {
1521     fetch();
1522     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1523         lrref();
1524     printdone "fetched to ".lrref()." and merged into HEAD";
1525 }
1526
1527 sub check_not_dirty () {
1528     return if $ignoredirty;
1529     my @cmd = (@git, qw(diff --quiet HEAD));
1530     debugcmd "+",@cmd;
1531     $!=0; $?=0; system @cmd;
1532     return if !$! && !$?;
1533     if (!$! && $?==256) {
1534         fail "working tree is dirty (does not match HEAD)";
1535     } else {
1536         failedcmd @cmd;
1537     }
1538 }
1539
1540 sub commit_admin ($) {
1541     my ($m) = @_;
1542     progress "$m";
1543     runcmd_ordryrun_local @git, qw(commit -m), $m;
1544 }
1545
1546 sub commit_quilty_patch () {
1547     my $output = cmdoutput @git, qw(status --porcelain);
1548     my %adds;
1549     foreach my $l (split /\n/, $output) {
1550         next unless $l =~ m/\S/;
1551         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1552             $adds{$1}++;
1553         }
1554     }
1555     delete $adds{'.pc'}; # if there wasn't one before, don't add it
1556     if (!%adds) {
1557         progress "nothing quilty to commit, ok.";
1558         return;
1559     }
1560     runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1561     commit_admin "Commit Debian 3.0 (quilt) metadata";
1562 }
1563
1564 sub get_source_format () {
1565     if (!open F, "debian/source/format") {
1566         die $! unless $!==&ENOENT;
1567         return '';
1568     }
1569     $_ = <F>;
1570     F->error and die $!;
1571     chomp;
1572     return $_;
1573 }
1574
1575 sub madformat ($) {
1576     my ($format) = @_;
1577     return 0 unless $format eq '3.0 (quilt)';
1578     if ($quilt_mode eq 'nocheck') {
1579         progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1580         return 0;
1581     }
1582     progress "Format \`$format', checking/updating patch stack";
1583     return 1;
1584 }
1585
1586 sub push_parse_changelog ($) {
1587     my ($clogpfn) = @_;
1588
1589     my $clogp = Dpkg::Control::Hash->new();
1590     $clogp->load($clogpfn) or die;
1591
1592     $package = getfield $clogp, 'Source';
1593     my $cversion = getfield $clogp, 'Version';
1594     my $tag = debiantag($cversion, access_basedistro);
1595     runcmd @git, qw(check-ref-format), $tag;
1596
1597     my $dscfn = dscfn($cversion);
1598
1599     return ($clogp, $cversion, $tag, $dscfn);
1600 }
1601
1602 sub push_parse_dsc ($$$) {
1603     my ($dscfn,$dscfnwhat, $cversion) = @_;
1604     $dsc = parsecontrol($dscfn,$dscfnwhat);
1605     my $dversion = getfield $dsc, 'Version';
1606     my $dscpackage = getfield $dsc, 'Source';
1607     ($dscpackage eq $package && $dversion eq $cversion) or
1608         fail "$dscfn is for $dscpackage $dversion".
1609             " but debian/changelog is for $package $cversion";
1610 }
1611
1612 sub push_mktag ($$$$$$$) {
1613     my ($head,$clogp,$tag,
1614         $dscfn,
1615         $changesfile,$changesfilewhat,
1616         $tfn) = @_;
1617
1618     $dsc->{$ourdscfield[0]} = $head;
1619     $dsc->save("$dscfn.tmp") or die $!;
1620
1621     my $changes = parsecontrol($changesfile,$changesfilewhat);
1622     foreach my $field (qw(Source Distribution Version)) {
1623         $changes->{$field} eq $clogp->{$field} or
1624             fail "changes field $field \`$changes->{$field}'".
1625                 " does not match changelog \`$clogp->{$field}'";
1626     }
1627
1628     my $cversion = getfield $clogp, 'Version';
1629     my $clogsuite = getfield $clogp, 'Distribution';
1630
1631     # We make the git tag by hand because (a) that makes it easier
1632     # to control the "tagger" (b) we can do remote signing
1633     my $authline = clogp_authline $clogp;
1634     my $delibs = join(" ", "",@deliberatelies);
1635     my $declaredistro = access_basedistro();
1636     open TO, '>', $tfn->('.tmp') or die $!;
1637     print TO <<END or die $!;
1638 object $head
1639 type commit
1640 tag $tag
1641 tagger $authline
1642
1643 $package release $cversion for $clogsuite ($csuite) [dgit]
1644 [dgit distro=$declaredistro$delibs]
1645 END
1646     foreach my $ref (sort keys %previously) {
1647                     print TO <<END or die $!;
1648 [dgit previously:$ref=$previously{$ref}]
1649 END
1650     }
1651
1652     close TO or die $!;
1653
1654     my $tagobjfn = $tfn->('.tmp');
1655     if ($sign) {
1656         if (!defined $keyid) {
1657             $keyid = access_cfg('keyid','RETURN-UNDEF');
1658         }
1659         unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1660         my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1661         push @sign_cmd, qw(-u),$keyid if defined $keyid;
1662         push @sign_cmd, $tfn->('.tmp');
1663         runcmd_ordryrun @sign_cmd;
1664         if (act_scary()) {
1665             $tagobjfn = $tfn->('.signed.tmp');
1666             runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1667                 $tfn->('.tmp'), $tfn->('.tmp.asc');
1668         }
1669     }
1670
1671     return ($tagobjfn);
1672 }
1673
1674 sub sign_changes ($) {
1675     my ($changesfile) = @_;
1676     if ($sign) {
1677         my @debsign_cmd = @debsign;
1678         push @debsign_cmd, "-k$keyid" if defined $keyid;
1679         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1680         push @debsign_cmd, $changesfile;
1681         runcmd_ordryrun @debsign_cmd;
1682     }
1683 }
1684
1685 sub dopush ($) {
1686     my ($forceflag) = @_;
1687     printdebug "actually entering push\n";
1688     prep_ud();
1689
1690     access_giturl(); # check that success is vaguely likely
1691
1692     my $clogpfn = ".git/dgit/changelog.822.tmp";
1693     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1694
1695     responder_send_file('parsed-changelog', $clogpfn);
1696
1697     my ($clogp, $cversion, $tag, $dscfn) =
1698         push_parse_changelog("$clogpfn");
1699
1700     my $dscpath = "$buildproductsdir/$dscfn";
1701     stat_exists $dscpath or
1702         fail "looked for .dsc $dscfn, but $!;".
1703             " maybe you forgot to build";
1704
1705     responder_send_file('dsc', $dscpath);
1706
1707     push_parse_dsc($dscpath, $dscfn, $cversion);
1708
1709     my $format = getfield $dsc, 'Format';
1710     printdebug "format $format\n";
1711     if (madformat($format)) {
1712         commit_quilty_patch();
1713     }
1714     check_not_dirty();
1715     changedir $ud;
1716     progress "checking that $dscfn corresponds to HEAD";
1717     runcmd qw(dpkg-source -x --),
1718         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1719     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1720     check_for_vendor_patches() if madformat($dsc->{format});
1721     changedir '../../../..';
1722     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1723     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1724     debugcmd "+",@diffcmd;
1725     $!=0; $?=0;
1726     my $r = system @diffcmd;
1727     if ($r) {
1728         if ($r==256) {
1729             fail "$dscfn specifies a different tree to your HEAD commit;".
1730                 " perhaps you forgot to build".
1731                 ($diffopt eq '--exit-code' ? "" :
1732                  " (run with -D to see full diff output)");
1733         } else {
1734             failedcmd @diffcmd;
1735         }
1736     }
1737 #fetch from alioth
1738 #do fast forward check and maybe fake merge
1739 #    if (!is_fast_fwd(mainbranch
1740 #    runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
1741 #        map { lref($_).":".rref($_) }
1742 #        (uploadbranch());
1743     my $head = git_rev_parse('HEAD');
1744     if (!$changesfile) {
1745         my $multi = "$buildproductsdir/".
1746             "${package}_".(stripepoch $cversion)."_multi.changes";
1747         if (stat_exists "$multi") {
1748             $changesfile = $multi;
1749         } else {
1750             my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1751             my @cs = glob "$buildproductsdir/$pat";
1752             fail "failed to find unique changes file".
1753                 " (looked for $pat in $buildproductsdir, or $multi);".
1754                 " perhaps you need to use dgit -C"
1755                 unless @cs==1;
1756             ($changesfile) = @cs;
1757         }
1758     } else {
1759         $changesfile = "$buildproductsdir/$changesfile";
1760     }
1761
1762     responder_send_file('changes',$changesfile);
1763     responder_send_command("param head $head");
1764     responder_send_command("param csuite $csuite");
1765
1766     if (deliberately_not_fast_forward) {
1767         git_for_each_ref(lrfetchrefs, sub {
1768             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1769             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1770             responder_send_command("previously $rrefname=$objid");
1771             $previously{$rrefname} = $objid;
1772         });
1773     }
1774
1775     my $tfn = sub { ".git/dgit/tag$_[0]"; };
1776     my $tagobjfn;
1777
1778     if ($we_are_responder) {
1779         $tagobjfn = $tfn->('.signed.tmp');
1780         responder_receive_files('signed-tag', $tagobjfn);
1781     } else {
1782         $tagobjfn =
1783             push_mktag($head,$clogp,$tag,
1784                        $dscpath,
1785                        $changesfile,$changesfile,
1786                        $tfn);
1787     }
1788
1789     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1790     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1791     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1792     runcmd_ordryrun @git, qw(tag -v --), $tag;
1793
1794     if (!check_for_git()) {
1795         create_remote_git_repo();
1796     }
1797     runcmd_ordryrun @git, qw(push),access_giturl(),
1798         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1799     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1800
1801     if ($we_are_responder) {
1802         my $dryrunsuffix = act_local() ? "" : ".tmp";
1803         responder_receive_files('signed-dsc-changes',
1804                                 "$dscpath$dryrunsuffix",
1805                                 "$changesfile$dryrunsuffix");
1806     } else {
1807         if (act_local()) {
1808             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1809         } else {
1810             progress "[new .dsc left in $dscpath.tmp]";
1811         }
1812         sign_changes $changesfile;
1813     }
1814
1815     my $host = access_cfg('upload-host','RETURN-UNDEF');
1816     my @hostarg = defined($host) ? ($host,) : ();
1817     runcmd_ordryrun @dput, @hostarg, $changesfile;
1818     printdone "pushed and uploaded $cversion";
1819
1820     responder_send_command("complete");
1821 }
1822
1823 sub cmd_clone {
1824     parseopts();
1825     my $dstdir;
1826     badusage "-p is not allowed with clone; specify as argument instead"
1827         if defined $package;
1828     if (@ARGV==1) {
1829         ($package) = @ARGV;
1830     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1831         ($package,$isuite) = @ARGV;
1832     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1833         ($package,$dstdir) = @ARGV;
1834     } elsif (@ARGV==3) {
1835         ($package,$isuite,$dstdir) = @ARGV;
1836     } else {
1837         badusage "incorrect arguments to dgit clone";
1838     }
1839     $dstdir ||= "$package";
1840
1841     if (stat_exists $dstdir) {
1842         fail "$dstdir already exists";
1843     }
1844
1845     my $cwd_remove;
1846     if ($rmonerror && !$dryrun_level) {
1847         $cwd_remove= getcwd();
1848         unshift @end, sub {
1849             return unless defined $cwd_remove;
1850             if (!chdir "$cwd_remove") {
1851                 return if $!==&ENOENT;
1852                 die "chdir $cwd_remove: $!";
1853             }
1854             rmtree($dstdir) or die "remove $dstdir: $!\n";
1855         };
1856     }
1857
1858     clone($dstdir);
1859     $cwd_remove = undef;
1860 }
1861
1862 sub branchsuite () {
1863     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1864     if ($branch =~ m#$lbranch_re#o) {
1865         return $1;
1866     } else {
1867         return undef;
1868     }
1869 }
1870
1871 sub fetchpullargs () {
1872     if (!defined $package) {
1873         my $sourcep = parsecontrol('debian/control','debian/control');
1874         $package = getfield $sourcep, 'Source';
1875     }
1876     if (@ARGV==0) {
1877 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
1878         if (!$isuite) {
1879             my $clogp = parsechangelog();
1880             $isuite = getfield $clogp, 'Distribution';
1881         }
1882         canonicalise_suite();
1883         progress "fetching from suite $csuite";
1884     } elsif (@ARGV==1) {
1885         ($isuite) = @ARGV;
1886         canonicalise_suite();
1887     } else {
1888         badusage "incorrect arguments to dgit fetch or dgit pull";
1889     }
1890 }
1891
1892 sub cmd_fetch {
1893     parseopts();
1894     fetchpullargs();
1895     fetch();
1896 }
1897
1898 sub cmd_pull {
1899     parseopts();
1900     fetchpullargs();
1901     pull();
1902 }
1903
1904 sub cmd_push {
1905     parseopts();
1906     badusage "-p is not allowed with dgit push" if defined $package;
1907     check_not_dirty();
1908     my $clogp = parsechangelog();
1909     $package = getfield $clogp, 'Source';
1910     my $specsuite;
1911     if (@ARGV==0) {
1912     } elsif (@ARGV==1) {
1913         ($specsuite) = (@ARGV);
1914     } else {
1915         badusage "incorrect arguments to dgit push";
1916     }
1917     $isuite = getfield $clogp, 'Distribution';
1918     if ($new_package) {
1919         local ($package) = $existing_package; # this is a hack
1920         canonicalise_suite();
1921     } else {
1922         canonicalise_suite();
1923     }
1924     if (defined $specsuite &&
1925         $specsuite ne $isuite &&
1926         $specsuite ne $csuite) {
1927             fail "dgit push: changelog specifies $isuite ($csuite)".
1928                 " but command line specifies $specsuite";
1929     }
1930     if (check_for_git()) {
1931         git_fetch_us();
1932     }
1933     my $forceflag = '';
1934     if (fetch_from_archive()) {
1935         if (is_fast_fwd(lrref(), 'HEAD')) {
1936             # ok
1937         } elsif (deliberately_not_fast_forward) {
1938             $forceflag = '+';
1939         } else {
1940             fail "dgit push: HEAD is not a descendant".
1941                 " of the archive's version.\n".
1942                 "dgit: To overwrite its contents,".
1943                 " use git merge -s ours ".lrref().".\n".
1944                 "dgit: To rewind history, if permitted by the archive,".
1945                 " use --deliberately-not-fast-forward";
1946         }
1947     } else {
1948         $new_package or
1949             fail "package appears to be new in this suite;".
1950                 " if this is intentional, use --new";
1951     }
1952     dopush($forceflag);
1953 }
1954
1955 #---------- remote commands' implementation ----------
1956
1957 sub cmd_remote_push_build_host {
1958     my ($nrargs) = shift @ARGV;
1959     my (@rargs) = @ARGV[0..$nrargs-1];
1960     @ARGV = @ARGV[$nrargs..$#ARGV];
1961     die unless @rargs;
1962     my ($dir,$vsnwant) = @rargs;
1963     # vsnwant is a comma-separated list; we report which we have
1964     # chosen in our ready response (so other end can tell if they
1965     # offered several)
1966     $debugprefix = ' ';
1967     $we_are_responder = 1;
1968     $us .= " (build host)";
1969
1970     open PI, "<&STDIN" or die $!;
1971     open STDIN, "/dev/null" or die $!;
1972     open PO, ">&STDOUT" or die $!;
1973     autoflush PO 1;
1974     open STDOUT, ">&STDERR" or die $!;
1975     autoflush STDOUT 1;
1976
1977     $vsnwant //= 1;
1978     fail "build host has dgit rpush protocol version".
1979         " $rpushprotovsn but invocation host has $vsnwant"
1980         unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
1981
1982     responder_send_command("dgit-remote-push-ready $rpushprotovsn");
1983
1984     changedir $dir;
1985     &cmd_push;
1986 }
1987
1988 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
1989 # ... for compatibility with proto vsn.1 dgit (just so that user gets
1990 #     a good error message)
1991
1992 our $i_tmp;
1993
1994 sub i_cleanup {
1995     local ($@, $?);
1996     my $report = i_child_report();
1997     if (defined $report) {
1998         printdebug "($report)\n";
1999     } elsif ($i_child_pid) {
2000         printdebug "(killing build host child $i_child_pid)\n";
2001         kill 15, $i_child_pid;
2002     }
2003     if (defined $i_tmp && !defined $initiator_tempdir) {
2004         changedir "/";
2005         eval { rmtree $i_tmp; };
2006     }
2007 }
2008
2009 END { i_cleanup(); }
2010
2011 sub i_method {
2012     my ($base,$selector,@args) = @_;
2013     $selector =~ s/\-/_/g;
2014     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2015 }
2016
2017 sub cmd_rpush {
2018     my $host = nextarg;
2019     my $dir;
2020     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2021         $host = $1;
2022         $dir = $'; #';
2023     } else {
2024         $dir = nextarg;
2025     }
2026     $dir =~ s{^-}{./-};
2027     my @rargs = ($dir,$rpushprotovsn);
2028     my @rdgit;
2029     push @rdgit, @dgit;
2030     push @rdgit, @ropts;
2031     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2032     push @rdgit, @ARGV;
2033     my @cmd = (@ssh, $host, shellquote @rdgit);
2034     debugcmd "+",@cmd;
2035
2036     if (defined $initiator_tempdir) {
2037         rmtree $initiator_tempdir;
2038         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2039         $i_tmp = $initiator_tempdir;
2040     } else {
2041         $i_tmp = tempdir();
2042     }
2043     $i_child_pid = open2(\*RO, \*RI, @cmd);
2044     changedir $i_tmp;
2045     initiator_expect { m/^dgit-remote-push-ready/ };
2046     for (;;) {
2047         my ($icmd,$iargs) = initiator_expect {
2048             m/^(\S+)(?: (.*))?$/;
2049             ($1,$2);
2050         };
2051         i_method "i_resp", $icmd, $iargs;
2052     }
2053 }
2054
2055 sub i_resp_progress ($) {
2056     my ($rhs) = @_;
2057     my $msg = protocol_read_bytes \*RO, $rhs;
2058     progress $msg;
2059 }
2060
2061 sub i_resp_complete {
2062     my $pid = $i_child_pid;
2063     $i_child_pid = undef; # prevents killing some other process with same pid
2064     printdebug "waiting for build host child $pid...\n";
2065     my $got = waitpid $pid, 0;
2066     die $! unless $got == $pid;
2067     die "build host child failed $?" if $?;
2068
2069     i_cleanup();
2070     printdebug "all done\n";
2071     exit 0;
2072 }
2073
2074 sub i_resp_file ($) {
2075     my ($keyword) = @_;
2076     my $localname = i_method "i_localname", $keyword;
2077     my $localpath = "$i_tmp/$localname";
2078     stat_exists $localpath and
2079         badproto \*RO, "file $keyword ($localpath) twice";
2080     protocol_receive_file \*RO, $localpath;
2081     i_method "i_file", $keyword;
2082 }
2083
2084 our %i_param;
2085
2086 sub i_resp_param ($) {
2087     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2088     $i_param{$1} = $2;
2089 }
2090
2091 sub i_resp_previously ($) {
2092     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2093         or badproto \*RO, "bad previously spec";
2094     my $r = system qw(git check-ref-format), $1;
2095     die "bad previously ref spec ($r)" if $r;
2096     $previously{$1} = $2;
2097 }
2098
2099 our %i_wanted;
2100
2101 sub i_resp_want ($) {
2102     my ($keyword) = @_;
2103     die "$keyword ?" if $i_wanted{$keyword}++;
2104     my @localpaths = i_method "i_want", $keyword;
2105     printdebug "[[  $keyword @localpaths\n";
2106     foreach my $localpath (@localpaths) {
2107         protocol_send_file \*RI, $localpath;
2108     }
2109     print RI "files-end\n" or die $!;
2110 }
2111
2112 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2113
2114 sub i_localname_parsed_changelog {
2115     return "remote-changelog.822";
2116 }
2117 sub i_file_parsed_changelog {
2118     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2119         push_parse_changelog "$i_tmp/remote-changelog.822";
2120     die if $i_dscfn =~ m#/|^\W#;
2121 }
2122
2123 sub i_localname_dsc {
2124     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2125     return $i_dscfn;
2126 }
2127 sub i_file_dsc { }
2128
2129 sub i_localname_changes {
2130     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2131     $i_changesfn = $i_dscfn;
2132     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2133     return $i_changesfn;
2134 }
2135 sub i_file_changes { }
2136
2137 sub i_want_signed_tag {
2138     printdebug Dumper(\%i_param, $i_dscfn);
2139     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2140         && defined $i_param{'csuite'}
2141         or badproto \*RO, "premature desire for signed-tag";
2142     my $head = $i_param{'head'};
2143     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2144
2145     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2146     $csuite = $&;
2147     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2148
2149     my $tagobjfn =
2150         push_mktag $head, $i_clogp, $i_tag,
2151             $i_dscfn,
2152             $i_changesfn, 'remote changes',
2153             sub { "tag$_[0]"; };
2154
2155     return $tagobjfn;
2156 }
2157
2158 sub i_want_signed_dsc_changes {
2159     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2160     sign_changes $i_changesfn;
2161     return ($i_dscfn, $i_changesfn);
2162 }
2163
2164 #---------- building etc. ----------
2165
2166 our $version;
2167 our $sourcechanges;
2168 our $dscfn;
2169
2170 #----- `3.0 (quilt)' handling -----
2171
2172 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2173
2174 sub quiltify_dpkg_commit ($$$;$) {
2175     my ($patchname,$author,$msg, $xinfo) = @_;
2176     $xinfo //= '';
2177
2178     mkpath '.git/dgit';
2179     my $descfn = ".git/dgit/quilt-description.tmp";
2180     open O, '>', $descfn or die "$descfn: $!";
2181     $msg =~ s/\s+$//g;
2182     $msg =~ s/\n/\n /g;
2183     $msg =~ s/^\s+$/ ./mg;
2184     print O <<END or die $!;
2185 Description: $msg
2186 Author: $author
2187 $xinfo
2188 ---
2189
2190 END
2191     close O or die $!;
2192
2193     {
2194         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2195         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2196         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2197         runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2198     }
2199 }
2200
2201 sub quiltify_trees_differ ($$) {
2202     my ($x,$y) = @_;
2203     # returns 1 iff the two tree objects differ other than in debian/
2204     local $/=undef;
2205     my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2206     my $diffs= cmdoutput @cmd;
2207     foreach my $f (split /\0/, $diffs) {
2208         next if $f eq 'debian';
2209         return 1;
2210     }
2211     return 0;
2212 }
2213
2214 sub quiltify_tree_sentinelfiles ($) {
2215     # lists the `sentinel' files present in the tree
2216     my ($x) = @_;
2217     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2218         qw(-- debian/rules debian/control);
2219     $r =~ s/\n/,/g;
2220     return $r;
2221 }
2222
2223 sub quiltify ($$) {
2224     my ($clogp,$target) = @_;
2225
2226     # Quilt patchification algorithm
2227     #
2228     # We search backwards through the history of the main tree's HEAD
2229     # (T) looking for a start commit S whose tree object is identical
2230     # to to the patch tip tree (ie the tree corresponding to the
2231     # current dpkg-committed patch series).  For these purposes
2232     # `identical' disregards anything in debian/ - this wrinkle is
2233     # necessary because dpkg-source treates debian/ specially.
2234     #
2235     # We can only traverse edges where at most one of the ancestors'
2236     # trees differs (in changes outside in debian/).  And we cannot
2237     # handle edges which change .pc/ or debian/patches.  To avoid
2238     # going down a rathole we avoid traversing edges which introduce
2239     # debian/rules or debian/control.  And we set a limit on the
2240     # number of edges we are willing to look at.
2241     #
2242     # If we succeed, we walk forwards again.  For each traversed edge
2243     # PC (with P parent, C child) (starting with P=S and ending with
2244     # C=T) to we do this:
2245     #  - git checkout C
2246     #  - dpkg-source --commit with a patch name and message derived from C
2247     # After traversing PT, we git commit the changes which
2248     # should be contained within debian/patches.
2249
2250     changedir '../fake';
2251     mktree_in_ud_here();
2252     rmtree '.pc';
2253     runcmd @git, 'add', '.';
2254     my $oldtiptree=git_write_tree();
2255     changedir '../work';
2256
2257     # The search for the path S..T is breadth-first.  We maintain a
2258     # todo list containing search nodes.  A search node identifies a
2259     # commit, and looks something like this:
2260     #  $p = {
2261     #      Commit => $git_commit_id,
2262     #      Child => $c,                          # or undef if P=T
2263     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2264     #      Nontrivial => true iff $p..$c has relevant changes
2265     #  };
2266
2267     my @todo;
2268     my @nots;
2269     my $sref_S;
2270     my $max_work=100;
2271     my %considered; # saves being exponential on some weird graphs
2272
2273     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2274
2275     my $not = sub {
2276         my ($search,$whynot) = @_;
2277         printdebug " search NOT $search->{Commit} $whynot\n";
2278         $search->{Whynot} = $whynot;
2279         push @nots, $search;
2280         no warnings qw(exiting);
2281         next;
2282     };
2283
2284     push @todo, {
2285         Commit => $target,
2286     };
2287
2288     while (@todo) {
2289         my $c = shift @todo;
2290         next if $considered{$c->{Commit}}++;
2291
2292         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2293
2294         printdebug "quiltify investigate $c->{Commit}\n";
2295
2296         # are we done?
2297         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2298             printdebug " search finished hooray!\n";
2299             $sref_S = $c;
2300             last;
2301         }
2302
2303         if ($quilt_mode eq 'nofix') {
2304             fail "quilt fixup required but quilt mode is \`nofix'\n".
2305                 "HEAD commit $c->{Commit} differs from tree implied by ".
2306                 " debian/patches (tree object $oldtiptree)";
2307         }
2308         if ($quilt_mode eq 'smash') {
2309             printdebug " search quitting smash\n";
2310             last;
2311         }
2312
2313         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2314         $not->($c, "has $c_sentinels not $t_sentinels")
2315             if $c_sentinels ne $t_sentinels;
2316
2317         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2318         $commitdata =~ m/\n\n/;
2319         $commitdata =~ $`;
2320         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2321         @parents = map { { Commit => $_, Child => $c } } @parents;
2322
2323         $not->($c, "root commit") if !@parents;
2324
2325         foreach my $p (@parents) {
2326             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2327         }
2328         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2329         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2330
2331         foreach my $p (@parents) {
2332             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2333
2334             my @cmd= (@git, qw(diff-tree -r --name-only),
2335                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2336             my $patchstackchange = cmdoutput @cmd;
2337             if (length $patchstackchange) {
2338                 $patchstackchange =~ s/\n/,/g;
2339                 $not->($p, "changed $patchstackchange");
2340             }
2341
2342             printdebug " search queue P=$p->{Commit} ",
2343                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2344             push @todo, $p;
2345         }
2346     }
2347
2348     if (!$sref_S) {
2349         printdebug "quiltify want to smash\n";
2350
2351         my $abbrev = sub {
2352             my $x = $_[0]{Commit};
2353             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2354             return $;
2355         };
2356         my $reportnot = sub {
2357             my ($notp) = @_;
2358             my $s = $abbrev->($notp);
2359             my $c = $notp->{Child};
2360             $s .= "..".$abbrev->($c) if $c;
2361             $s .= ": ".$notp->{Whynot};
2362             return $s;
2363         };
2364         if ($quilt_mode eq 'linear') {
2365             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2366             foreach my $notp (@nots) {
2367                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2368             }
2369             fail "quilt fixup naive history linearisation failed.\n".
2370  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2371         } elsif ($quilt_mode eq 'smash') {
2372         } elsif ($quilt_mode eq 'auto') {
2373             progress "quilt fixup cannot be linear, smashing...";
2374         } else {
2375             die "$quilt_mode ?";
2376         }
2377
2378         my $time = time;
2379         my $ncommits = 3;
2380         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2381
2382         quiltify_dpkg_commit "auto-$version-$target-$time",
2383             (getfield $clogp, 'Maintainer'),
2384             "Automatically generated patch ($clogp->{Version})\n".
2385             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2386         return;
2387     }
2388
2389     progress "quiltify linearisation planning successful, executing...";
2390
2391     for (my $p = $sref_S;
2392          my $c = $p->{Child};
2393          $p = $p->{Child}) {
2394         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2395         next unless $p->{Nontrivial};
2396
2397         my $cc = $c->{Commit};
2398
2399         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2400         $commitdata =~ m/\n\n/ or die "$c ?";
2401         $commitdata = $`;
2402         my $msg = $'; #';
2403         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2404         my $author = $1;
2405
2406         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2407
2408         my $title = $1;
2409         my $patchname = $title;
2410         $patchname =~ s/[.:]$//;
2411         $patchname =~ y/ A-Z/-a-z/;
2412         $patchname =~ y/-a-z0-9_.+=~//cd;
2413         $patchname =~ s/^\W/x-$&/;
2414         $patchname = substr($patchname,0,40);
2415         my $index;
2416         for ($index='';
2417              stat "debian/patches/$patchname$index";
2418              $index++) { }
2419         $!==ENOENT or die "$patchname$index $!";
2420
2421         runcmd @git, qw(checkout -q), $cc;
2422
2423         # We use the tip's changelog so that dpkg-source doesn't
2424         # produce complaining messages from dpkg-parsechangelog.  None
2425         # of the information dpkg-source gets from the changelog is
2426         # actually relevant - it gets put into the original message
2427         # which dpkg-source provides our stunt editor, and then
2428         # overwritten.
2429         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2430
2431         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2432             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2433
2434         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2435     }
2436
2437     runcmd @git, qw(checkout -q master);
2438 }
2439
2440 sub build_maybe_quilt_fixup () {
2441     my $format=get_source_format;
2442     return unless madformat $format;
2443     # sigh
2444
2445     check_for_vendor_patches();
2446
2447     # Our objective is:
2448     #  - honour any existing .pc in case it has any strangeness
2449     #  - determine the git commit corresponding to the tip of
2450     #    the patch stack (if there is one)
2451     #  - if there is such a git commit, convert each subsequent
2452     #    git commit into a quilt patch with dpkg-source --commit
2453     #  - otherwise convert all the differences in the tree into
2454     #    a single git commit
2455     #
2456     # To do this we:
2457
2458     # Our git tree doesn't necessarily contain .pc.  (Some versions of
2459     # dgit would include the .pc in the git tree.)  If there isn't
2460     # one, we need to generate one by unpacking the patches that we
2461     # have.
2462     #
2463     # We first look for a .pc in the git tree.  If there is one, we
2464     # will use it.  (This is not the normal case.)
2465     #
2466     # Otherwise need to regenerate .pc so that dpkg-source --commit
2467     # can work.  We do this as follows:
2468     #     1. Collect all relevant .orig from parent directory
2469     #     2. Generate a debian.tar.gz out of
2470     #         debian/{patches,rules,source/format}
2471     #     3. Generate a fake .dsc containing just these fields:
2472     #          Format Source Version Files
2473     #     4. Extract the fake .dsc
2474     #        Now the fake .dsc has a .pc directory.
2475     # (In fact we do this in every case, because in future we will
2476     # want to search for a good base commit for generating patches.)
2477     #
2478     # Then we can actually do the dpkg-source --commit
2479     #     1. Make a new working tree with the same object
2480     #        store as our main tree and check out the main
2481     #        tree's HEAD.
2482     #     2. Copy .pc from the fake's extraction, if necessary
2483     #     3. Run dpkg-source --commit
2484     #     4. If the result has changes to debian/, then
2485     #          - git-add them them
2486     #          - git-add .pc if we had a .pc in-tree
2487     #          - git-commit
2488     #     5. If we had a .pc in-tree, delete it, and git-commit
2489     #     6. Back in the main tree, fast forward to the new HEAD
2490
2491     my $clogp = parsechangelog();
2492     my $headref = git_rev_parse('HEAD');
2493
2494     prep_ud();
2495     changedir $ud;
2496
2497     my $upstreamversion=$version;
2498     $upstreamversion =~ s/-[^-]*$//;
2499
2500     my $fakeversion="$upstreamversion-~~DGITFAKE";
2501
2502     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2503     print $fakedsc <<END or die $!;
2504 Format: 3.0 (quilt)
2505 Source: $package
2506 Version: $fakeversion
2507 Files:
2508 END
2509
2510     my $dscaddfile=sub {
2511         my ($b) = @_;
2512
2513         my $md = new Digest::MD5;
2514
2515         my $fh = new IO::File $b, '<' or die "$b $!";
2516         stat $fh or die $!;
2517         my $size = -s _;
2518
2519         $md->addfile($fh);
2520         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2521     };
2522
2523     foreach my $f (<../../../../*>) { #/){
2524         my $b=$f; $b =~ s{.*/}{};
2525         next unless is_orig_file $b, srcfn $upstreamversion,'';
2526         link $f, $b or die "$b $!";
2527         $dscaddfile->($b);
2528     }
2529
2530     my @files=qw(debian/source/format debian/rules);
2531     if (stat_exists '../../../debian/patches') {
2532         push @files, 'debian/patches';
2533     }
2534
2535     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2536     runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2537
2538     $dscaddfile->($debtar);
2539     close $fakedsc or die $!;
2540
2541     runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2542
2543     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2544     rename $fakexdir, "fake" or die "$fakexdir $!";
2545
2546     mkdir "work" or die $!;
2547     changedir "work";
2548     mktree_in_ud_here();
2549     runcmd @git, qw(reset --hard), $headref;
2550
2551     my $mustdeletepc=0;
2552     if (stat_exists ".pc") {
2553         -d _ or die;
2554         progress "Tree already contains .pc - will use it then delete it.";
2555         $mustdeletepc=1;
2556     } else {
2557         rename '../fake/.pc','.pc' or die $!;
2558     }
2559
2560     quiltify($clogp,$headref);
2561
2562     if (!open P, '>>', ".pc/applied-patches") {
2563         $!==&ENOENT or die $!;
2564     } else {
2565         close P;
2566     }
2567
2568     commit_quilty_patch();
2569
2570     if ($mustdeletepc) {
2571         runcmd @git, qw(rm -rqf .pc);
2572         commit_admin "Commit removal of .pc (quilt series tracking data)";
2573     }
2574
2575     changedir '../../../..';
2576     runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2577 }
2578
2579 sub quilt_fixup_editor () {
2580     my $descfn = $ENV{$fakeeditorenv};
2581     my $editing = $ARGV[$#ARGV];
2582     open I1, '<', $descfn or die "$descfn: $!";
2583     open I2, '<', $editing or die "$editing: $!";
2584     unlink $editing or die "$editing: $!";
2585     open O, '>', $editing or die "$editing: $!";
2586     while (<I1>) { print O or die $!; } I1->error and die $!;
2587     my $copying = 0;
2588     while (<I2>) {
2589         $copying ||= m/^\-\-\- /;
2590         next unless $copying;
2591         print O or die $!;
2592     }
2593     I2->error and die $!;
2594     close O or die $1;
2595     exit 0;
2596 }
2597
2598 #----- other building -----
2599
2600 sub clean_tree () {
2601     if ($cleanmode eq 'dpkg-source') {
2602         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2603     } elsif ($cleanmode eq 'git') {
2604         runcmd_ordryrun_local @git, qw(clean -xdf);
2605     } elsif ($cleanmode eq 'none') {
2606     } else {
2607         die "$cleanmode ?";
2608     }
2609 }
2610
2611 sub cmd_clean () {
2612     badusage "clean takes no additional arguments" if @ARGV;
2613     clean_tree();
2614 }
2615
2616 sub build_prep () {
2617     badusage "-p is not allowed when building" if defined $package;
2618     check_not_dirty();
2619     clean_tree();
2620     my $clogp = parsechangelog();
2621     $isuite = getfield $clogp, 'Distribution';
2622     $package = getfield $clogp, 'Source';
2623     $version = getfield $clogp, 'Version';
2624     build_maybe_quilt_fixup();
2625 }
2626
2627 sub changesopts () {
2628     my @opts =@changesopts[1..$#changesopts];
2629     if (!defined $changes_since_version) {
2630         my @vsns = archive_query('archive_query');
2631         my @quirk = access_quirk();
2632         if ($quirk[0] eq 'backports') {
2633             local $isuite = $quirk[2];
2634             local $csuite;
2635             canonicalise_suite();
2636             push @vsns, archive_query('archive_query');
2637         }
2638         if (@vsns) {
2639             @vsns = map { $_->[0] } @vsns;
2640             @vsns = sort { -version_compare($a, $b) } @vsns;
2641             $changes_since_version = $vsns[0];
2642             progress "changelog will contain changes since $vsns[0]";
2643         } else {
2644             $changes_since_version = '_';
2645             progress "package seems new, not specifying -v<version>";
2646         }
2647     }
2648     if ($changes_since_version ne '_') {
2649         unshift @opts, "-v$changes_since_version";
2650     }
2651     return @opts;
2652 }
2653
2654 sub massage_dbp_args ($) {
2655     my ($cmd) = @_;
2656     return unless $cleanmode =~ m/git|none/;
2657     debugcmd '#massaging#', @$cmd if $debuglevel>1;
2658     my @newcmd = shift @$cmd;
2659     # -nc has the side effect of specifying -b if nothing else specified
2660     push @newcmd, '-nc';
2661     # and some combinations of -S, -b, et al, are errors, rather than
2662     # later simply overriding earlier
2663     push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2664     push @newcmd, @$cmd;
2665     @$cmd = @newcmd;
2666 }
2667
2668 sub cmd_build {
2669     build_prep();
2670     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2671     massage_dbp_args \@dbp;
2672     runcmd_ordryrun_local @dbp;
2673     printdone "build successful\n";
2674 }
2675
2676 sub cmd_git_build {
2677     build_prep();
2678     my @dbp = @dpkgbuildpackage;
2679     massage_dbp_args \@dbp;
2680     my @cmd =
2681         (qw(git-buildpackage -us -uc --git-no-sign-tags),
2682          "--git-builder=@dbp");
2683     unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2684         canonicalise_suite();
2685         push @cmd, "--git-debian-branch=".lbranch();
2686     }
2687     push @cmd, changesopts();
2688     runcmd_ordryrun_local @cmd, @ARGV;
2689     printdone "build successful\n";
2690 }
2691
2692 sub build_source {
2693     build_prep();
2694     $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2695     $dscfn = dscfn($version);
2696     if ($cleanmode eq 'dpkg-source') {
2697         runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2698             changesopts();
2699     } else {
2700         my $pwd = must_getcwd();
2701         my $leafdir = basename $pwd;
2702         changedir "..";
2703         runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2704         changedir $pwd;
2705         runcmd_ordryrun_local qw(sh -ec),
2706             'exec >$1; shift; exec "$@"','x',
2707             "../$sourcechanges",
2708             @dpkggenchanges, qw(-S), changesopts();
2709     }
2710 }
2711
2712 sub cmd_build_source {
2713     badusage "build-source takes no additional arguments" if @ARGV;
2714     build_source();
2715     printdone "source built, results in $dscfn and $sourcechanges";
2716 }
2717
2718 sub cmd_sbuild {
2719     build_source();
2720     changedir "..";
2721     my $pat = "${package}_".(stripepoch $version)."_*.changes";
2722     if (act_local()) {
2723         stat_exist $dscfn or fail "$dscfn (in parent directory): $!";
2724         stat_exists $sourcechanges
2725             or fail "$sourcechanges (in parent directory): $!";
2726         foreach my $cf (glob $pat) {
2727             next if $cf eq $sourcechanges;
2728             unlink $cf or fail "remove $cf: $!";
2729         }
2730     }
2731     runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2732     my @changesfiles = glob $pat;
2733     @changesfiles = sort {
2734         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2735             or $a cmp $b
2736     } @changesfiles;
2737     fail "wrong number of different changes files (@changesfiles)"
2738         unless @changesfiles;
2739     runcmd_ordryrun_local @mergechanges, @changesfiles;
2740     my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2741     if (act_local()) {
2742         stat_exists $multichanges or fail "$multichanges: $!";
2743     }
2744     printdone "build successful, results in $multichanges\n" or die $!;
2745 }
2746
2747 sub cmd_quilt_fixup {
2748     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2749     my $clogp = parsechangelog();
2750     $version = getfield $clogp, 'Version';
2751     $package = getfield $clogp, 'Source';
2752     build_maybe_quilt_fixup();
2753 }
2754
2755 sub cmd_archive_api_query {
2756     badusage "need only 1 subpath argument" unless @ARGV==1;
2757     my ($subpath) = @ARGV;
2758     my @cmd = archive_api_query_cmd($subpath);
2759     debugcmd ">",@cmd;
2760     exec @cmd or fail "exec curl: $!\n";
2761 }
2762
2763 sub cmd_clone_dgit_repos_server {
2764     badusage "need destination argument" unless @ARGV==1;
2765     my ($destdir) = @ARGV;
2766     $package = '_dgit-repos-server';
2767     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2768     debugcmd ">",@cmd;
2769     exec @cmd or fail "exec git clone: $!\n";
2770 }
2771
2772 #---------- argument parsing and main program ----------
2773
2774 sub cmd_version {
2775     print "dgit version $our_version\n" or die $!;
2776     exit 0;
2777 }
2778
2779 sub parseopts () {
2780     my $om;
2781
2782     if (defined $ENV{'DGIT_SSH'}) {
2783         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2784     } elsif (defined $ENV{'GIT_SSH'}) {
2785         @ssh = ($ENV{'GIT_SSH'});
2786     }
2787
2788     while (@ARGV) {
2789         last unless $ARGV[0] =~ m/^-/;
2790         $_ = shift @ARGV;
2791         last if m/^--?$/;
2792         if (m/^--/) {
2793             if (m/^--dry-run$/) {
2794                 push @ropts, $_;
2795                 $dryrun_level=2;
2796             } elsif (m/^--damp-run$/) {
2797                 push @ropts, $_;
2798                 $dryrun_level=1;
2799             } elsif (m/^--no-sign$/) {
2800                 push @ropts, $_;
2801                 $sign=0;
2802             } elsif (m/^--help$/) {
2803                 cmd_help();
2804             } elsif (m/^--version$/) {
2805                 cmd_version();
2806             } elsif (m/^--new$/) {
2807                 push @ropts, $_;
2808                 $new_package=1;
2809             } elsif (m/^--since-version=([^_]+|_)$/) {
2810                 push @ropts, $_;
2811                 $changes_since_version = $1;
2812             } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2813                      ($om = $opts_opt_map{$1}) &&
2814                      length $om->[0]) {
2815                 push @ropts, $_;
2816                 $om->[0] = $2;
2817             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2818                      !$opts_opt_cmdonly{$1} &&
2819                      ($om = $opts_opt_map{$1})) {
2820                 push @ropts, $_;
2821                 push @$om, $2;
2822             } elsif (m/^--existing-package=(.*)/s) {
2823                 push @ropts, $_;
2824                 $existing_package = $1;
2825             } elsif (m/^--initiator-tempdir=(.*)/s) {
2826                 $initiator_tempdir = $1;
2827                 $initiator_tempdir =~ m#^/# or
2828                     badusage "--initiator-tempdir must be used specify an".
2829                         " absolute, not relative, directory."
2830             } elsif (m/^--distro=(.*)/s) {
2831                 push @ropts, $_;
2832                 $idistro = $1;
2833             } elsif (m/^--build-products-dir=(.*)/s) {
2834                 push @ropts, $_;
2835                 $buildproductsdir = $1;
2836             } elsif (m/^--clean=(dpkg-source|git|none)$/s) {
2837                 push @ropts, $_;
2838                 $cleanmode = $1;
2839             } elsif (m/^--clean=(.*)$/s) {
2840                 badusage "unknown cleaning mode \`$1'";
2841             } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2842                 push @ropts, $_;
2843                 $quilt_mode = $1;
2844             } elsif (m/^--quilt=(.*)$/s) {
2845                 badusage "unknown quilt fixup mode \`$1'";
2846             } elsif (m/^--ignore-dirty$/s) {
2847                 push @ropts, $_;
2848                 $ignoredirty = 1;
2849             } elsif (m/^--no-quilt-fixup$/s) {
2850                 push @ropts, $_;
2851                 $quilt_mode = 'nocheck';
2852             } elsif (m/^--no-rm-on-error$/s) {
2853                 push @ropts, $_;
2854                 $rmonerror = 0;
2855             } elsif (m/^--deliberately-($deliberately_re)$/s) {
2856                 push @ropts, $_;
2857                 push @deliberatelies, $&;
2858             } else {
2859                 badusage "unknown long option \`$_'";
2860             }
2861         } else {
2862             while (m/^-./s) {
2863                 if (s/^-n/-/) {
2864                     push @ropts, $&;
2865                     $dryrun_level=2;
2866                 } elsif (s/^-L/-/) {
2867                     push @ropts, $&;
2868                     $dryrun_level=1;
2869                 } elsif (s/^-h/-/) {
2870                     cmd_help();
2871                 } elsif (s/^-D/-/) {
2872                     push @ropts, $&;
2873                     $debuglevel++;
2874                     enabledebug();
2875                 } elsif (s/^-N/-/) {
2876                     push @ropts, $&;
2877                     $new_package=1;
2878                 } elsif (s/^-v([^_]+|_)$//s) {
2879                     push @ropts, $&;
2880                     $changes_since_version = $1;
2881                 } elsif (m/^-m/) {
2882                     push @ropts, $&;
2883                     push @changesopts, $_;
2884                     $_ = '';
2885                 } elsif (s/^-c(.*=.*)//s) {
2886                     push @ropts, $&;
2887                     push @git, '-c', $1;
2888                 } elsif (s/^-d(.+)//s) {
2889                     push @ropts, $&;
2890                     $idistro = $1;
2891                 } elsif (s/^-C(.+)//s) {
2892                     push @ropts, $&;
2893                     $changesfile = $1;
2894                     if ($changesfile =~ s#^(.*)/##) {
2895                         $buildproductsdir = $1;
2896                     }
2897                 } elsif (s/^-k(.+)//s) {
2898                     $keyid=$1;
2899                 } elsif (m/^-[vdCk]$/) {
2900                     badusage
2901  "option \`$_' requires an argument (and no space before the argument)";
2902                 } elsif (s/^-wn$//s) {
2903                     push @ropts, $&;
2904                     $cleanmode = 'none';
2905                 } elsif (s/^-wg$//s) {
2906                     push @ropts, $&;
2907                     $cleanmode = 'git';
2908                 } elsif (s/^-wd$//s) {
2909                     push @ropts, $&;
2910                     $cleanmode = 'dpkg-source';
2911                 } else {
2912                     badusage "unknown short option \`$_'";
2913                 }
2914             }
2915         }
2916     }
2917 }
2918
2919 if ($ENV{$fakeeditorenv}) {
2920     quilt_fixup_editor();
2921 }
2922
2923 parseopts();
2924 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
2925 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
2926     if $dryrun_level == 1;
2927 if (!@ARGV) {
2928     print STDERR $helpmsg or die $!;
2929     exit 8;
2930 }
2931 my $cmd = shift @ARGV;
2932 $cmd =~ y/-/_/;
2933
2934 if (!defined $quilt_mode) {
2935     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
2936         // access_cfg('quilt-mode', 'RETURN-UNDEF')
2937         // 'linear';
2938     $quilt_mode =~ m/^($quilt_modes_re)$/
2939         or badcfg "unknown quilt-mode \`$quilt_mode'";
2940     $quilt_mode = $1;
2941 }
2942
2943 my $fn = ${*::}{"cmd_$cmd"};
2944 $fn or badusage "unknown operation $cmd";
2945 $fn->();