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