dgit

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