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