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