dgit

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