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