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