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