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