dgit

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