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