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