dgit

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