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