dgit

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