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 $authline;
1325 }
1326
1327 sub vendor_patches_distro ($$) {
1328     my ($checkdistro, $what) = @_;
1329     return unless defined $checkdistro;
1330
1331     my $series = "debian/patches/\L$checkdistro\E.series";
1332     printdebug "checking for vendor-specific $series ($what)\n";
1333
1334     if (!open SERIES, "<", $series) {
1335         die "$series $!" unless $!==ENOENT;
1336         return;
1337     }
1338     while (<SERIES>) {
1339         next unless m/\S/;
1340         next if m/^\s+\#/;
1341
1342         print STDERR <<END;
1343
1344 Unfortunately, this source package uses a feature of dpkg-source where
1345 the same source package unpacks to different source code on different
1346 distros.  dgit cannot safely operate on such packages on affected
1347 distros, because the meaning of source packages is not stable.
1348
1349 Please ask the distro/maintainer to remove the distro-specific series
1350 files and use a different technique (if necessary, uploading actually
1351 different packages, if different distros are supposed to have
1352 different code).
1353
1354 END
1355         fail "Found active distro-specific series file for".
1356             " $checkdistro ($what): $series, cannot continue";
1357     }
1358     die "$series $!" if SERIES->error;
1359     close SERIES;
1360 }
1361
1362 sub check_for_vendor_patches () {
1363     # This dpkg-source feature doesn't seem to be documented anywhere!
1364     # But it can be found in the changelog (reformatted):
1365
1366     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1367     #   Author: Raphael Hertzog <hertzog@debian.org>
1368     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1369
1370     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1371     #   series files
1372     #
1373     #   If you have debian/patches/ubuntu.series and you were
1374     #   unpacking the source package on ubuntu, quilt was still
1375     #   directed to debian/patches/series instead of
1376     #   debian/patches/ubuntu.series.
1377     #
1378     #   debian/changelog                        |    3 +++
1379     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1380     #   2 files changed, 6 insertions(+), 1 deletion(-)
1381
1382     use Dpkg::Vendor;
1383     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1384     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1385                          "Dpkg::Vendor \`current vendor'");
1386     vendor_patches_distro(access_basedistro(),
1387                           "distro being accessed");
1388 }
1389
1390 sub generate_commit_from_dsc () {
1391     prep_ud();
1392     changedir $ud;
1393
1394     foreach my $fi (dsc_files_info()) {
1395         my $f = $fi->{Filename};
1396         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1397
1398         link_ltarget "../../../$f", $f
1399             or $!==&ENOENT
1400             or die "$f $!";
1401
1402         complete_file_from_dsc('.', $fi)
1403             or next;
1404
1405         if (is_orig_file($f)) {
1406             link $f, "../../../../$f"
1407                 or $!==&EEXIST
1408                 or die "$f $!";
1409         }
1410     }
1411
1412     my $dscfn = "$package.dsc";
1413
1414     open D, ">", $dscfn or die "$dscfn: $!";
1415     print D $dscdata or die "$dscfn: $!";
1416     close D or die "$dscfn: $!";
1417     my @cmd = qw(dpkg-source);
1418     push @cmd, '--no-check' if $dsc_checked;
1419     push @cmd, qw(-x --), $dscfn;
1420     runcmd @cmd;
1421
1422     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1423     check_for_vendor_patches() if madformat($dsc->{format});
1424     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1425     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1426     my $authline = clogp_authline $clogp;
1427     my $changes = getfield $clogp, 'Changes';
1428     open C, ">../commit.tmp" or die $!;
1429     print C <<END or die $!;
1430 tree $tree
1431 author $authline
1432 committer $authline
1433
1434 $changes
1435
1436 # imported from the archive
1437 END
1438     close C or die $!;
1439     my $outputhash = make_commit qw(../commit.tmp);
1440     my $cversion = getfield $clogp, 'Version';
1441     progress "synthesised git commit from .dsc $cversion";
1442     if ($lastpush_hash) {
1443         runcmd @git, qw(reset --hard), $lastpush_hash;
1444         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1445         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1446         my $oversion = getfield $oldclogp, 'Version';
1447         my $vcmp =
1448             version_compare($oversion, $cversion);
1449         if ($vcmp < 0) {
1450             # git upload/ is earlier vsn than archive, use archive
1451             open C, ">../commit2.tmp" or die $!;
1452             print C <<END or die $!;
1453 tree $tree
1454 parent $lastpush_hash
1455 parent $outputhash
1456 author $authline
1457 committer $authline
1458
1459 Record $package ($cversion) in archive suite $csuite
1460 END
1461             $outputhash = make_commit qw(../commit2.tmp);
1462         } elsif ($vcmp > 0) {
1463             print STDERR <<END or die $!;
1464
1465 Version actually in archive:    $cversion (older)
1466 Last allegedly pushed/uploaded: $oversion (newer or same)
1467 $later_warning_msg
1468 END
1469             $outputhash = $lastpush_hash;
1470         } else {
1471             $outputhash = $lastpush_hash;
1472         }
1473     }
1474     changedir '../../../..';
1475     runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1476             'DGIT_ARCHIVE', $outputhash;
1477     cmdoutput @git, qw(log -n2), $outputhash;
1478     # ... gives git a chance to complain if our commit is malformed
1479     rmtree($ud);
1480     return $outputhash;
1481 }
1482
1483 sub complete_file_from_dsc ($$) {
1484     our ($dstdir, $fi) = @_;
1485     # Ensures that we have, in $dir, the file $fi, with the correct
1486     # contents.  (Downloading it from alongside $dscurl if necessary.)
1487
1488     my $f = $fi->{Filename};
1489     my $tf = "$dstdir/$f";
1490     my $downloaded = 0;
1491
1492     if (stat_exists $tf) {
1493         progress "using existing $f";
1494     } else {
1495         my $furl = $dscurl;
1496         $furl =~ s{/[^/]+$}{};
1497         $furl .= "/$f";
1498         die "$f ?" unless $f =~ m/^\Q${package}\E_/;
1499         die "$f ?" if $f =~ m#/#;
1500         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1501         return 0 if !act_local();
1502         $downloaded = 1;
1503     }
1504
1505     open F, "<", "$tf" or die "$tf: $!";
1506     $fi->{Digester}->reset();
1507     $fi->{Digester}->addfile(*F);
1508     F->error and die $!;
1509     my $got = $fi->{Digester}->hexdigest();
1510     $got eq $fi->{Hash} or
1511         fail "file $f has hash $got but .dsc".
1512             " demands hash $fi->{Hash} ".
1513             ($downloaded ? "(got wrong file from archive!)"
1514              : "(perhaps you should delete this file?)");
1515
1516     return 1;
1517 }
1518
1519 sub ensure_we_have_orig () {
1520     foreach my $fi (dsc_files_info()) {
1521         my $f = $fi->{Filename};
1522         next unless is_orig_file($f);
1523         complete_file_from_dsc('..', $fi)
1524             or next;
1525     }
1526 }
1527
1528 sub git_fetch_us () {
1529     my @specs = (fetchspec());
1530     push @specs,
1531         map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1532         qw(tags heads);
1533     runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1534
1535     my %here;
1536     my $tagpat = debiantag('*',access_basedistro);
1537
1538     git_for_each_ref("refs/tags/".$tagpat, sub {
1539         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1540         printdebug "currently $fullrefname=$objid\n";
1541         $here{$fullrefname} = $objid;
1542     });
1543     git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1544         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1545         my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1546         printdebug "offered $lref=$objid\n";
1547         if (!defined $here{$lref}) {
1548             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1549             runcmd_ordryrun_local @upd;
1550         } elsif ($here{$lref} eq $objid) {
1551         } else {
1552             print STDERR \
1553                 "Not updateting $lref from $here{$lref} to $objid.\n";
1554         }
1555     });
1556 }
1557
1558 sub fetch_from_archive () {
1559     # ensures that lrref() is what is actually in the archive,
1560     #  one way or another
1561     get_archive_dsc();
1562
1563     if ($dsc) {
1564         foreach my $field (@ourdscfield) {
1565             $dsc_hash = $dsc->{$field};
1566             last if defined $dsc_hash;
1567         }
1568         if (defined $dsc_hash) {
1569             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1570             $dsc_hash = $&;
1571             progress "last upload to archive specified git hash";
1572         } else {
1573             progress "last upload to archive has NO git hash";
1574         }
1575     } else {
1576         progress "no version available from the archive";
1577     }
1578
1579     $lastpush_hash = git_get_ref(lrref());
1580     printdebug "previous reference hash=$lastpush_hash\n";
1581     my $hash;
1582     if (defined $dsc_hash) {
1583         fail "missing remote git history even though dsc has hash -".
1584             " could not find ref ".lrref().
1585             " (should have been fetched from ".access_giturl()."#".rrref().")"
1586             unless $lastpush_hash;
1587         $hash = $dsc_hash;
1588         ensure_we_have_orig();
1589         if ($dsc_hash eq $lastpush_hash) {
1590         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1591             print STDERR <<END or die $!;
1592
1593 Git commit in archive is behind the last version allegedly pushed/uploaded.
1594 Commit referred to by archive:  $dsc_hash
1595 Last allegedly pushed/uploaded: $lastpush_hash
1596 $later_warning_msg
1597 END
1598             $hash = $lastpush_hash;
1599         } else {
1600             fail "git head (".lrref()."=$lastpush_hash) is not a ".
1601                 "descendant of archive's .dsc hash ($dsc_hash)";
1602         }
1603     } elsif ($dsc) {
1604         $hash = generate_commit_from_dsc();
1605     } elsif ($lastpush_hash) {
1606         # only in git, not in the archive yet
1607         $hash = $lastpush_hash;
1608         print STDERR <<END or die $!;
1609
1610 Package not found in the archive, but has allegedly been pushed using dgit.
1611 $later_warning_msg
1612 END
1613     } else {
1614         printdebug "nothing found!\n";
1615         if (defined $skew_warning_vsn) {
1616             print STDERR <<END or die $!;
1617
1618 Warning: relevant archive skew detected.
1619 Archive allegedly contains $skew_warning_vsn
1620 But we were not able to obtain any version from the archive or git.
1621
1622 END
1623         }
1624         return 0;
1625     }
1626     printdebug "current hash=$hash\n";
1627     if ($lastpush_hash) {
1628         fail "not fast forward on last upload branch!".
1629             " (archive's version left in DGIT_ARCHIVE)"
1630             unless is_fast_fwd($lastpush_hash, $hash);
1631     }
1632     if (defined $skew_warning_vsn) {
1633         mkpath '.git/dgit';
1634         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1635         my $clogf = ".git/dgit/changelog.tmp";
1636         runcmd shell_cmd "exec >$clogf",
1637             @git, qw(cat-file blob), "$hash:debian/changelog";
1638         my $gotclogp = parsechangelog("-l$clogf");
1639         my $got_vsn = getfield $gotclogp, 'Version';
1640         printdebug "SKEW CHECK GOT $got_vsn\n";
1641         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1642             print STDERR <<END or die $!;
1643
1644 Warning: archive skew detected.  Using the available version:
1645 Archive allegedly contains    $skew_warning_vsn
1646 We were able to obtain only   $got_vsn
1647
1648 END
1649         }
1650     }
1651     if ($lastpush_hash ne $hash) {
1652         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1653         if (act_local()) {
1654             cmdoutput @upd_cmd;
1655         } else {
1656             dryrun_report @upd_cmd;
1657         }
1658     }
1659     return 1;
1660 }
1661
1662 sub set_local_git_config ($$) {
1663     my ($k, $v) = @_;
1664     runcmd @git, qw(config), $k, $v;
1665 }
1666
1667 sub setup_mergechangelogs (;$) {
1668     my ($always) = @_;
1669     return unless $always || access_cfg_bool(1, 'setup-mergechangelogs');
1670
1671     my $driver = 'dpkg-mergechangelogs';
1672     my $cb = "merge.$driver";
1673     my $attrs = '.git/info/attributes';
1674     ensuredir '.git/info';
1675
1676     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1677     if (!open ATTRS, "<", $attrs) {
1678         $!==ENOENT or die "$attrs: $!";
1679     } else {
1680         while (<ATTRS>) {
1681             chomp;
1682             next if m{^debian/changelog\s};
1683             print NATTRS $_, "\n" or die $!;
1684         }
1685         ATTRS->error and die $!;
1686         close ATTRS;
1687     }
1688     print NATTRS "debian/changelog merge=$driver\n" or die $!;
1689     close NATTRS;
1690
1691     set_local_git_config "$cb.name", 'debian/changelog merge driver';
1692     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1693
1694     rename "$attrs.new", "$attrs" or die "$attrs: $!";
1695 }
1696
1697 sub setup_useremail (;$) {
1698     my ($always) = @_;
1699     return unless $always || access_cfg_bool(1, 'setup-useremail');
1700
1701     my $setup = sub {
1702         my ($k, $envvar) = @_;
1703         my $v = access_cfg("user-$k", 'RETURN-UNDEF') // $ENV{$envvar};
1704         return unless defined $v;
1705         set_local_git_config "user.$k", $v;
1706     };
1707
1708     $setup->('email', 'DEBEMAIL');
1709     $setup->('name', 'DEBFULLNAME');
1710 }
1711
1712 sub setup_new_tree () {
1713     setup_mergechangelogs();
1714     setup_useremail();
1715 }
1716
1717 sub clone ($) {
1718     my ($dstdir) = @_;
1719     canonicalise_suite();
1720     badusage "dry run makes no sense with clone" unless act_local();
1721     my $hasgit = check_for_git();
1722     mkdir $dstdir or fail "create \`$dstdir': $!";
1723     changedir $dstdir;
1724     runcmd @git, qw(init -q);
1725     my $giturl = access_giturl(1);
1726     if (defined $giturl) {
1727         set_local_git_config "remote.$remotename.fetch", fetchspec();
1728         open H, "> .git/HEAD" or die $!;
1729         print H "ref: ".lref()."\n" or die $!;
1730         close H or die $!;
1731         runcmd @git, qw(remote add), 'origin', $giturl;
1732     }
1733     if ($hasgit) {
1734         progress "fetching existing git history";
1735         git_fetch_us();
1736         runcmd_ordryrun_local @git, qw(fetch origin);
1737     } else {
1738         progress "starting new git history";
1739     }
1740     fetch_from_archive() or no_such_package;
1741     my $vcsgiturl = $dsc->{'Vcs-Git'};
1742     if (length $vcsgiturl) {
1743         $vcsgiturl =~ s/\s+-b\s+\S+//g;
1744         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1745     }
1746     setup_new_tree();
1747     runcmd @git, qw(reset --hard), lrref();
1748     printdone "ready for work in $dstdir";
1749 }
1750
1751 sub fetch () {
1752     if (check_for_git()) {
1753         git_fetch_us();
1754     }
1755     fetch_from_archive() or no_such_package();
1756     printdone "fetched into ".lrref();
1757 }
1758
1759 sub pull () {
1760     fetch();
1761     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1762         lrref();
1763     printdone "fetched to ".lrref()." and merged into HEAD";
1764 }
1765
1766 sub check_not_dirty () {
1767     foreach my $f (qw(local-options local-patch-header)) {
1768         if (stat_exists "debian/source/$f") {
1769             fail "git tree contains debian/source/$f";
1770         }
1771     }
1772
1773     return if $ignoredirty;
1774
1775     my @cmd = (@git, qw(diff --quiet HEAD));
1776     debugcmd "+",@cmd;
1777     $!=0; $?=0; system @cmd;
1778     return if !$! && !$?;
1779     if (!$! && $?==256) {
1780         fail "working tree is dirty (does not match HEAD)";
1781     } else {
1782         failedcmd @cmd;
1783     }
1784 }
1785
1786 sub commit_admin ($) {
1787     my ($m) = @_;
1788     progress "$m";
1789     runcmd_ordryrun_local @git, qw(commit -m), $m;
1790 }
1791
1792 sub commit_quilty_patch () {
1793     my $output = cmdoutput @git, qw(status --porcelain);
1794     my %adds;
1795     foreach my $l (split /\n/, $output) {
1796         next unless $l =~ m/\S/;
1797         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1798             $adds{$1}++;
1799         }
1800     }
1801     delete $adds{'.pc'}; # if there wasn't one before, don't add it
1802     if (!%adds) {
1803         progress "nothing quilty to commit, ok.";
1804         return;
1805     }
1806     my @adds = map { s/[][*?\\]/\\$&/g; $_; } sort keys %adds;
1807     runcmd_ordryrun_local @git, qw(add -f), @adds;
1808     commit_admin "Commit Debian 3.0 (quilt) metadata";
1809 }
1810
1811 sub get_source_format () {
1812     my %options;
1813     if (open F, "debian/source/options") {
1814         while (<F>) {
1815             next if m/^\s*\#/;
1816             next unless m/\S/;
1817             s/\s+$//; # ignore missing final newline
1818             if (m/\s*\#\s*/) {
1819                 my ($k, $v) = ($`, $'); #');
1820                 $v =~ s/^"(.*)"$/$1/;
1821                 $options{$k} = $v;
1822             } else {
1823                 $options{$_} = 1;
1824             }
1825         }
1826         F->error and die $!;
1827         close F;
1828     } else {
1829         die $! unless $!==&ENOENT;
1830     }
1831
1832     if (!open F, "debian/source/format") {
1833         die $! unless $!==&ENOENT;
1834         return '';
1835     }
1836     $_ = <F>;
1837     F->error and die $!;
1838     chomp;
1839     return ($_, \%options);
1840 }
1841
1842 sub madformat ($) {
1843     my ($format) = @_;
1844     return 0 unless $format eq '3.0 (quilt)';
1845     if ($quilt_mode eq 'nocheck') {
1846         progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1847         return 0;
1848     }
1849     progress "Format \`$format', checking/updating patch stack";
1850     return 1;
1851 }
1852
1853 sub push_parse_changelog ($) {
1854     my ($clogpfn) = @_;
1855
1856     my $clogp = Dpkg::Control::Hash->new();
1857     $clogp->load($clogpfn) or die;
1858
1859     $package = getfield $clogp, 'Source';
1860     my $cversion = getfield $clogp, 'Version';
1861     my $tag = debiantag($cversion, access_basedistro);
1862     runcmd @git, qw(check-ref-format), $tag;
1863
1864     my $dscfn = dscfn($cversion);
1865
1866     return ($clogp, $cversion, $tag, $dscfn);
1867 }
1868
1869 sub push_parse_dsc ($$$) {
1870     my ($dscfn,$dscfnwhat, $cversion) = @_;
1871     $dsc = parsecontrol($dscfn,$dscfnwhat);
1872     my $dversion = getfield $dsc, 'Version';
1873     my $dscpackage = getfield $dsc, 'Source';
1874     ($dscpackage eq $package && $dversion eq $cversion) or
1875         fail "$dscfn is for $dscpackage $dversion".
1876             " but debian/changelog is for $package $cversion";
1877 }
1878
1879 sub push_mktag ($$$$$$$) {
1880     my ($head,$clogp,$tag,
1881         $dscfn,
1882         $changesfile,$changesfilewhat,
1883         $tfn) = @_;
1884
1885     $dsc->{$ourdscfield[0]} = $head;
1886     $dsc->save("$dscfn.tmp") or die $!;
1887
1888     my $changes = parsecontrol($changesfile,$changesfilewhat);
1889     foreach my $field (qw(Source Distribution Version)) {
1890         $changes->{$field} eq $clogp->{$field} or
1891             fail "changes field $field \`$changes->{$field}'".
1892                 " does not match changelog \`$clogp->{$field}'";
1893     }
1894
1895     my $cversion = getfield $clogp, 'Version';
1896     my $clogsuite = getfield $clogp, 'Distribution';
1897
1898     # We make the git tag by hand because (a) that makes it easier
1899     # to control the "tagger" (b) we can do remote signing
1900     my $authline = clogp_authline $clogp;
1901     my $delibs = join(" ", "",@deliberatelies);
1902     my $declaredistro = access_basedistro();
1903     open TO, '>', $tfn->('.tmp') or die $!;
1904     print TO <<END or die $!;
1905 object $head
1906 type commit
1907 tag $tag
1908 tagger $authline
1909
1910 $package release $cversion for $clogsuite ($csuite) [dgit]
1911 [dgit distro=$declaredistro$delibs]
1912 END
1913     foreach my $ref (sort keys %previously) {
1914                     print TO <<END or die $!;
1915 [dgit previously:$ref=$previously{$ref}]
1916 END
1917     }
1918
1919     close TO or die $!;
1920
1921     my $tagobjfn = $tfn->('.tmp');
1922     if ($sign) {
1923         if (!defined $keyid) {
1924             $keyid = access_cfg('keyid','RETURN-UNDEF');
1925         }
1926         if (!defined $keyid) {
1927             $keyid = getfield $clogp, 'Maintainer';
1928         }
1929         unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1930         my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1931         push @sign_cmd, qw(-u),$keyid if defined $keyid;
1932         push @sign_cmd, $tfn->('.tmp');
1933         runcmd_ordryrun @sign_cmd;
1934         if (act_scary()) {
1935             $tagobjfn = $tfn->('.signed.tmp');
1936             runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1937                 $tfn->('.tmp'), $tfn->('.tmp.asc');
1938         }
1939     }
1940
1941     return ($tagobjfn);
1942 }
1943
1944 sub sign_changes ($) {
1945     my ($changesfile) = @_;
1946     if ($sign) {
1947         my @debsign_cmd = @debsign;
1948         push @debsign_cmd, "-k$keyid" if defined $keyid;
1949         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1950         push @debsign_cmd, $changesfile;
1951         runcmd_ordryrun @debsign_cmd;
1952     }
1953 }
1954
1955 sub dopush ($) {
1956     my ($forceflag) = @_;
1957     printdebug "actually entering push\n";
1958     supplementary_message(<<'END');
1959 Push failed, while preparing your push.
1960 You can retry the push, after fixing the problem, if you like.
1961 END
1962     prep_ud();
1963
1964     access_giturl(); # check that success is vaguely likely
1965
1966     my $clogpfn = ".git/dgit/changelog.822.tmp";
1967     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1968
1969     responder_send_file('parsed-changelog', $clogpfn);
1970
1971     my ($clogp, $cversion, $tag, $dscfn) =
1972         push_parse_changelog("$clogpfn");
1973
1974     my $dscpath = "$buildproductsdir/$dscfn";
1975     stat_exists $dscpath or
1976         fail "looked for .dsc $dscfn, but $!;".
1977             " maybe you forgot to build";
1978
1979     responder_send_file('dsc', $dscpath);
1980
1981     push_parse_dsc($dscpath, $dscfn, $cversion);
1982
1983     my $format = getfield $dsc, 'Format';
1984     printdebug "format $format\n";
1985     if (madformat($format)) {
1986         # user might have not used dgit build, so maybe do this now:
1987         commit_quilty_patch();
1988     }
1989     check_not_dirty();
1990     changedir $ud;
1991     progress "checking that $dscfn corresponds to HEAD";
1992     runcmd qw(dpkg-source -x --),
1993         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1994     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1995     check_for_vendor_patches() if madformat($dsc->{format});
1996     changedir '../../../..';
1997     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1998     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1999     debugcmd "+",@diffcmd;
2000     $!=0; $?=0;
2001     my $r = system @diffcmd;
2002     if ($r) {
2003         if ($r==256) {
2004             fail "$dscfn specifies a different tree to your HEAD commit;".
2005                 " perhaps you forgot to build".
2006                 ($diffopt eq '--exit-code' ? "" :
2007                  " (run with -D to see full diff output)");
2008         } else {
2009             failedcmd @diffcmd;
2010         }
2011     }
2012     my $head = git_rev_parse('HEAD');
2013     if (!$changesfile) {
2014         my $pat = changespat $cversion;
2015         my @cs = glob "$buildproductsdir/$pat";
2016         fail "failed to find unique changes file".
2017             " (looked for $pat in $buildproductsdir);".
2018             " perhaps you need to use dgit -C"
2019             unless @cs==1;
2020         ($changesfile) = @cs;
2021     } else {
2022         $changesfile = "$buildproductsdir/$changesfile";
2023     }
2024
2025     responder_send_file('changes',$changesfile);
2026     responder_send_command("param head $head");
2027     responder_send_command("param csuite $csuite");
2028
2029     if (deliberately_not_fast_forward) {
2030         git_for_each_ref(lrfetchrefs, sub {
2031             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2032             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2033             responder_send_command("previously $rrefname=$objid");
2034             $previously{$rrefname} = $objid;
2035         });
2036     }
2037
2038     my $tfn = sub { ".git/dgit/tag$_[0]"; };
2039     my $tagobjfn;
2040
2041     supplementary_message(<<'END');
2042 Push failed, while signing the tag.
2043 You can retry the push, after fixing the problem, if you like.
2044 END
2045     # If we manage to sign but fail to record it anywhere, it's fine.
2046     if ($we_are_responder) {
2047         $tagobjfn = $tfn->('.signed.tmp');
2048         responder_receive_files('signed-tag', $tagobjfn);
2049     } else {
2050         $tagobjfn =
2051             push_mktag($head,$clogp,$tag,
2052                        $dscpath,
2053                        $changesfile,$changesfile,
2054                        $tfn);
2055     }
2056     supplementary_message(<<'END');
2057 Push failed, *after* signing the tag.
2058 If you want to try again, you should use a new version number.
2059 END
2060
2061     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2062     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2063     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2064
2065     supplementary_message(<<'END');
2066 Push failed, while updating the remote git repository - see messages above.
2067 If you want to try again, you should use a new version number.
2068 END
2069     if (!check_for_git()) {
2070         create_remote_git_repo();
2071     }
2072     runcmd_ordryrun @git, qw(push),access_giturl(),
2073         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2074     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2075
2076     supplementary_message(<<'END');
2077 Push failed, after updating the remote git repository.
2078 If you want to try again, you must use a new version number.
2079 END
2080     if ($we_are_responder) {
2081         my $dryrunsuffix = act_local() ? "" : ".tmp";
2082         responder_receive_files('signed-dsc-changes',
2083                                 "$dscpath$dryrunsuffix",
2084                                 "$changesfile$dryrunsuffix");
2085     } else {
2086         if (act_local()) {
2087             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2088         } else {
2089             progress "[new .dsc left in $dscpath.tmp]";
2090         }
2091         sign_changes $changesfile;
2092     }
2093
2094     supplementary_message(<<END);
2095 Push failed, while uploading package(s) to the archive server.
2096 You can retry the upload of exactly these same files with dput of:
2097   $changesfile
2098 If that .changes file is broken, you will need to use a new version
2099 number for your next attempt at the upload.
2100 END
2101     my $host = access_cfg('upload-host','RETURN-UNDEF');
2102     my @hostarg = defined($host) ? ($host,) : ();
2103     runcmd_ordryrun @dput, @hostarg, $changesfile;
2104     printdone "pushed and uploaded $cversion";
2105
2106     supplementary_message('');
2107     responder_send_command("complete");
2108 }
2109
2110 sub cmd_clone {
2111     parseopts();
2112     notpushing();
2113     my $dstdir;
2114     badusage "-p is not allowed with clone; specify as argument instead"
2115         if defined $package;
2116     if (@ARGV==1) {
2117         ($package) = @ARGV;
2118     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2119         ($package,$isuite) = @ARGV;
2120     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2121         ($package,$dstdir) = @ARGV;
2122     } elsif (@ARGV==3) {
2123         ($package,$isuite,$dstdir) = @ARGV;
2124     } else {
2125         badusage "incorrect arguments to dgit clone";
2126     }
2127     $dstdir ||= "$package";
2128
2129     if (stat_exists $dstdir) {
2130         fail "$dstdir already exists";
2131     }
2132
2133     my $cwd_remove;
2134     if ($rmonerror && !$dryrun_level) {
2135         $cwd_remove= getcwd();
2136         unshift @end, sub {
2137             return unless defined $cwd_remove;
2138             if (!chdir "$cwd_remove") {
2139                 return if $!==&ENOENT;
2140                 die "chdir $cwd_remove: $!";
2141             }
2142             if (stat $dstdir) {
2143                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2144             } elsif (!grep { $! == $_ }
2145                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2146             } else {
2147                 print STDERR "check whether to remove $dstdir: $!\n";
2148             }
2149         };
2150     }
2151
2152     clone($dstdir);
2153     $cwd_remove = undef;
2154 }
2155
2156 sub branchsuite () {
2157     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2158     if ($branch =~ m#$lbranch_re#o) {
2159         return $1;
2160     } else {
2161         return undef;
2162     }
2163 }
2164
2165 sub fetchpullargs () {
2166     notpushing();
2167     if (!defined $package) {
2168         my $sourcep = parsecontrol('debian/control','debian/control');
2169         $package = getfield $sourcep, 'Source';
2170     }
2171     if (@ARGV==0) {
2172 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2173         if (!$isuite) {
2174             my $clogp = parsechangelog();
2175             $isuite = getfield $clogp, 'Distribution';
2176         }
2177         canonicalise_suite();
2178         progress "fetching from suite $csuite";
2179     } elsif (@ARGV==1) {
2180         ($isuite) = @ARGV;
2181         canonicalise_suite();
2182     } else {
2183         badusage "incorrect arguments to dgit fetch or dgit pull";
2184     }
2185 }
2186
2187 sub cmd_fetch {
2188     parseopts();
2189     fetchpullargs();
2190     fetch();
2191 }
2192
2193 sub cmd_pull {
2194     parseopts();
2195     fetchpullargs();
2196     pull();
2197 }
2198
2199 sub cmd_push {
2200     parseopts();
2201     pushing();
2202     badusage "-p is not allowed with dgit push" if defined $package;
2203     check_not_dirty();
2204     my $clogp = parsechangelog();
2205     $package = getfield $clogp, 'Source';
2206     my $specsuite;
2207     if (@ARGV==0) {
2208     } elsif (@ARGV==1) {
2209         ($specsuite) = (@ARGV);
2210     } else {
2211         badusage "incorrect arguments to dgit push";
2212     }
2213     $isuite = getfield $clogp, 'Distribution';
2214     if ($new_package) {
2215         local ($package) = $existing_package; # this is a hack
2216         canonicalise_suite();
2217     } else {
2218         canonicalise_suite();
2219     }
2220     if (defined $specsuite &&
2221         $specsuite ne $isuite &&
2222         $specsuite ne $csuite) {
2223             fail "dgit push: changelog specifies $isuite ($csuite)".
2224                 " but command line specifies $specsuite";
2225     }
2226     supplementary_message(<<'END');
2227 Push failed, while checking state of the archive.
2228 You can retry the push, after fixing the problem, if you like.
2229 END
2230     if (check_for_git()) {
2231         git_fetch_us();
2232     }
2233     my $forceflag = '';
2234     if (fetch_from_archive()) {
2235         if (is_fast_fwd(lrref(), 'HEAD')) {
2236             # ok
2237         } elsif (deliberately_not_fast_forward) {
2238             $forceflag = '+';
2239         } else {
2240             fail "dgit push: HEAD is not a descendant".
2241                 " of the archive's version.\n".
2242                 "dgit: To overwrite its contents,".
2243                 " use git merge -s ours ".lrref().".\n".
2244                 "dgit: To rewind history, if permitted by the archive,".
2245                 " use --deliberately-not-fast-forward";
2246         }
2247     } else {
2248         $new_package or
2249             fail "package appears to be new in this suite;".
2250                 " if this is intentional, use --new";
2251     }
2252     dopush($forceflag);
2253 }
2254
2255 #---------- remote commands' implementation ----------
2256
2257 sub cmd_remote_push_build_host {
2258     my ($nrargs) = shift @ARGV;
2259     my (@rargs) = @ARGV[0..$nrargs-1];
2260     @ARGV = @ARGV[$nrargs..$#ARGV];
2261     die unless @rargs;
2262     my ($dir,$vsnwant) = @rargs;
2263     # vsnwant is a comma-separated list; we report which we have
2264     # chosen in our ready response (so other end can tell if they
2265     # offered several)
2266     $debugprefix = ' ';
2267     $we_are_responder = 1;
2268     $us .= " (build host)";
2269
2270     pushing();
2271
2272     open PI, "<&STDIN" or die $!;
2273     open STDIN, "/dev/null" or die $!;
2274     open PO, ">&STDOUT" or die $!;
2275     autoflush PO 1;
2276     open STDOUT, ">&STDERR" or die $!;
2277     autoflush STDOUT 1;
2278
2279     $vsnwant //= 1;
2280     ($protovsn) = grep {
2281         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2282     } @rpushprotovsn_support;
2283
2284     fail "build host has dgit rpush protocol versions ".
2285         (join ",", @rpushprotovsn_support).
2286         " but invocation host has $vsnwant"
2287         unless defined $protovsn;
2288
2289     responder_send_command("dgit-remote-push-ready $protovsn");
2290
2291     changedir $dir;
2292     &cmd_push;
2293 }
2294
2295 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2296 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2297 #     a good error message)
2298
2299 our $i_tmp;
2300
2301 sub i_cleanup {
2302     local ($@, $?);
2303     my $report = i_child_report();
2304     if (defined $report) {
2305         printdebug "($report)\n";
2306     } elsif ($i_child_pid) {
2307         printdebug "(killing build host child $i_child_pid)\n";
2308         kill 15, $i_child_pid;
2309     }
2310     if (defined $i_tmp && !defined $initiator_tempdir) {
2311         changedir "/";
2312         eval { rmtree $i_tmp; };
2313     }
2314 }
2315
2316 END { i_cleanup(); }
2317
2318 sub i_method {
2319     my ($base,$selector,@args) = @_;
2320     $selector =~ s/\-/_/g;
2321     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2322 }
2323
2324 sub cmd_rpush {
2325     pushing();
2326     my $host = nextarg;
2327     my $dir;
2328     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2329         $host = $1;
2330         $dir = $'; #';
2331     } else {
2332         $dir = nextarg;
2333     }
2334     $dir =~ s{^-}{./-};
2335     my @rargs = ($dir);
2336     push @rargs, join ",", @rpushprotovsn_support;
2337     my @rdgit;
2338     push @rdgit, @dgit;
2339     push @rdgit, @ropts;
2340     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2341     push @rdgit, @ARGV;
2342     my @cmd = (@ssh, $host, shellquote @rdgit);
2343     debugcmd "+",@cmd;
2344
2345     if (defined $initiator_tempdir) {
2346         rmtree $initiator_tempdir;
2347         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2348         $i_tmp = $initiator_tempdir;
2349     } else {
2350         $i_tmp = tempdir();
2351     }
2352     $i_child_pid = open2(\*RO, \*RI, @cmd);
2353     changedir $i_tmp;
2354     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2355     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2356     $supplementary_message = '' unless $protovsn >= 3;
2357     for (;;) {
2358         my ($icmd,$iargs) = initiator_expect {
2359             m/^(\S+)(?: (.*))?$/;
2360             ($1,$2);
2361         };
2362         i_method "i_resp", $icmd, $iargs;
2363     }
2364 }
2365
2366 sub i_resp_progress ($) {
2367     my ($rhs) = @_;
2368     my $msg = protocol_read_bytes \*RO, $rhs;
2369     progress $msg;
2370 }
2371
2372 sub i_resp_supplementary_message ($) {
2373     my ($rhs) = @_;
2374     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2375 }
2376
2377 sub i_resp_complete {
2378     my $pid = $i_child_pid;
2379     $i_child_pid = undef; # prevents killing some other process with same pid
2380     printdebug "waiting for build host child $pid...\n";
2381     my $got = waitpid $pid, 0;
2382     die $! unless $got == $pid;
2383     die "build host child failed $?" if $?;
2384
2385     i_cleanup();
2386     printdebug "all done\n";
2387     exit 0;
2388 }
2389
2390 sub i_resp_file ($) {
2391     my ($keyword) = @_;
2392     my $localname = i_method "i_localname", $keyword;
2393     my $localpath = "$i_tmp/$localname";
2394     stat_exists $localpath and
2395         badproto \*RO, "file $keyword ($localpath) twice";
2396     protocol_receive_file \*RO, $localpath;
2397     i_method "i_file", $keyword;
2398 }
2399
2400 our %i_param;
2401
2402 sub i_resp_param ($) {
2403     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2404     $i_param{$1} = $2;
2405 }
2406
2407 sub i_resp_previously ($) {
2408     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2409         or badproto \*RO, "bad previously spec";
2410     my $r = system qw(git check-ref-format), $1;
2411     die "bad previously ref spec ($r)" if $r;
2412     $previously{$1} = $2;
2413 }
2414
2415 our %i_wanted;
2416
2417 sub i_resp_want ($) {
2418     my ($keyword) = @_;
2419     die "$keyword ?" if $i_wanted{$keyword}++;
2420     my @localpaths = i_method "i_want", $keyword;
2421     printdebug "[[  $keyword @localpaths\n";
2422     foreach my $localpath (@localpaths) {
2423         protocol_send_file \*RI, $localpath;
2424     }
2425     print RI "files-end\n" or die $!;
2426 }
2427
2428 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2429
2430 sub i_localname_parsed_changelog {
2431     return "remote-changelog.822";
2432 }
2433 sub i_file_parsed_changelog {
2434     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2435         push_parse_changelog "$i_tmp/remote-changelog.822";
2436     die if $i_dscfn =~ m#/|^\W#;
2437 }
2438
2439 sub i_localname_dsc {
2440     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2441     return $i_dscfn;
2442 }
2443 sub i_file_dsc { }
2444
2445 sub i_localname_changes {
2446     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2447     $i_changesfn = $i_dscfn;
2448     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2449     return $i_changesfn;
2450 }
2451 sub i_file_changes { }
2452
2453 sub i_want_signed_tag {
2454     printdebug Dumper(\%i_param, $i_dscfn);
2455     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2456         && defined $i_param{'csuite'}
2457         or badproto \*RO, "premature desire for signed-tag";
2458     my $head = $i_param{'head'};
2459     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2460
2461     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2462     $csuite = $&;
2463     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2464
2465     my $tagobjfn =
2466         push_mktag $head, $i_clogp, $i_tag,
2467             $i_dscfn,
2468             $i_changesfn, 'remote changes',
2469             sub { "tag$_[0]"; };
2470
2471     return $tagobjfn;
2472 }
2473
2474 sub i_want_signed_dsc_changes {
2475     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2476     sign_changes $i_changesfn;
2477     return ($i_dscfn, $i_changesfn);
2478 }
2479
2480 #---------- building etc. ----------
2481
2482 our $version;
2483 our $sourcechanges;
2484 our $dscfn;
2485
2486 #----- `3.0 (quilt)' handling -----
2487
2488 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2489
2490 sub quiltify_dpkg_commit ($$$;$) {
2491     my ($patchname,$author,$msg, $xinfo) = @_;
2492     $xinfo //= '';
2493
2494     mkpath '.git/dgit';
2495     my $descfn = ".git/dgit/quilt-description.tmp";
2496     open O, '>', $descfn or die "$descfn: $!";
2497     $msg =~ s/\s+$//g;
2498     $msg =~ s/\n/\n /g;
2499     $msg =~ s/^\s+$/ ./mg;
2500     print O <<END or die $!;
2501 Description: $msg
2502 Author: $author
2503 $xinfo
2504 ---
2505
2506 END
2507     close O or die $!;
2508
2509     {
2510         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2511         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2512         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2513         runcmd @dpkgsource, qw(--commit .), $patchname;
2514     }
2515 }
2516
2517 sub quiltify_trees_differ ($$;$) {
2518     my ($x,$y,$finegrained) = @_;
2519     # returns true iff the two tree objects differ other than in debian/
2520     # with $finegrained,
2521     # returns bitmask 01 - differ in upstream files except .gitignore
2522     #                 02 - differ in .gitignore
2523     local $/=undef;
2524     my @cmd = (@git, qw(diff-tree --name-only -z));
2525     push @cmd, qw(-r) if $finegrained;
2526     push @cmd, $x, $y;
2527     my $diffs= cmdoutput @cmd;
2528     my $r = 0;
2529     foreach my $f (split /\0/, $diffs) {
2530         next if $f =~ m#^debian(?:/.*)?$#s;
2531         $r |= ($f =~ m#^(?:.*/)?.gitignore$#s) ? 02 : 01;
2532     }
2533     printdebug "quiltify_trees_differ $x $y => $r\n";
2534     return $r;
2535 }
2536
2537 sub quiltify_tree_sentinelfiles ($) {
2538     # lists the `sentinel' files present in the tree
2539     my ($x) = @_;
2540     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2541         qw(-- debian/rules debian/control);
2542     $r =~ s/\n/,/g;
2543     return $r;
2544                                  }
2545
2546 sub quiltify_splitbrain_needed () {
2547     if (!$split_brain) {
2548         progress "creating dgit view";
2549         runcmd @git, qw(checkout -q -b dgit-view);
2550         $split_brain = 1;
2551     }
2552 }
2553
2554 sub quiltify_splitbrain ($) {
2555     my ($diffbits) = @_;
2556     if ($quilt_mode !~ m/gbp|dpm/) {
2557         # treat .gitignore just like any other upstream file
2558         $diffbits = { %$diffbits };
2559         $_ = !!$_ foreach values %$diffbits;
2560     }
2561     if ($quilt_mode =~ m/gbp|unapplied/ &&
2562         ($diffbits->{O2A} & 01) && # some patches
2563         !($diffbits->{H2O} & 01)) { # but HEAD is like orig
2564         quiltify_splitbrain_needed();
2565         runcmd @gbppq, qw(import);
2566         die "SPLIT BRAIN";
2567     }
2568     die 'xxx gitignore';
2569     die 'xxx memoisation via git-reflog';
2570     die 'xxx fast forward';
2571 }
2572
2573 sub quiltify ($$$$) {
2574     my ($clogp,$target,$oldtiptree,$failsuggestion) = @_;
2575
2576     # Quilt patchification algorithm
2577     #
2578     # We search backwards through the history of the main tree's HEAD
2579     # (T) looking for a start commit S whose tree object is identical
2580     # to to the patch tip tree (ie the tree corresponding to the
2581     # current dpkg-committed patch series).  For these purposes
2582     # `identical' disregards anything in debian/ - this wrinkle is
2583     # necessary because dpkg-source treates debian/ specially.
2584     #
2585     # We can only traverse edges where at most one of the ancestors'
2586     # trees differs (in changes outside in debian/).  And we cannot
2587     # handle edges which change .pc/ or debian/patches.  To avoid
2588     # going down a rathole we avoid traversing edges which introduce
2589     # debian/rules or debian/control.  And we set a limit on the
2590     # number of edges we are willing to look at.
2591     #
2592     # If we succeed, we walk forwards again.  For each traversed edge
2593     # PC (with P parent, C child) (starting with P=S and ending with
2594     # C=T) to we do this:
2595     #  - git checkout C
2596     #  - dpkg-source --commit with a patch name and message derived from C
2597     # After traversing PT, we git commit the changes which
2598     # should be contained within debian/patches.
2599
2600     # The search for the path S..T is breadth-first.  We maintain a
2601     # todo list containing search nodes.  A search node identifies a
2602     # commit, and looks something like this:
2603     #  $p = {
2604     #      Commit => $git_commit_id,
2605     #      Child => $c,                          # or undef if P=T
2606     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2607     #      Nontrivial => true iff $p..$c has relevant changes
2608     #  };
2609
2610     my @todo;
2611     my @nots;
2612     my $sref_S;
2613     my $max_work=100;
2614     my %considered; # saves being exponential on some weird graphs
2615
2616     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2617
2618     my $not = sub {
2619         my ($search,$whynot) = @_;
2620         printdebug " search NOT $search->{Commit} $whynot\n";
2621         $search->{Whynot} = $whynot;
2622         push @nots, $search;
2623         no warnings qw(exiting);
2624         next;
2625     };
2626
2627     push @todo, {
2628         Commit => $target,
2629     };
2630
2631     while (@todo) {
2632         my $c = shift @todo;
2633         next if $considered{$c->{Commit}}++;
2634
2635         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2636
2637         printdebug "quiltify investigate $c->{Commit}\n";
2638
2639         # are we done?
2640         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2641             printdebug " search finished hooray!\n";
2642             $sref_S = $c;
2643             last;
2644         }
2645
2646         if ($quilt_mode eq 'nofix') {
2647             fail "quilt fixup required but quilt mode is \`nofix'\n".
2648                 "HEAD commit $c->{Commit} differs from tree implied by ".
2649                 " debian/patches (tree object $oldtiptree)";
2650         }
2651         if ($quilt_mode eq 'smash') {
2652             printdebug " search quitting smash\n";
2653             last;
2654         }
2655
2656         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2657         $not->($c, "has $c_sentinels not $t_sentinels")
2658             if $c_sentinels ne $t_sentinels;
2659
2660         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2661         $commitdata =~ m/\n\n/;
2662         $commitdata =~ $`;
2663         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2664         @parents = map { { Commit => $_, Child => $c } } @parents;
2665
2666         $not->($c, "root commit") if !@parents;
2667
2668         foreach my $p (@parents) {
2669             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2670         }
2671         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2672         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2673
2674         foreach my $p (@parents) {
2675             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2676
2677             my @cmd= (@git, qw(diff-tree -r --name-only),
2678                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2679             my $patchstackchange = cmdoutput @cmd;
2680             if (length $patchstackchange) {
2681                 $patchstackchange =~ s/\n/,/g;
2682                 $not->($p, "changed $patchstackchange");
2683             }
2684
2685             printdebug " search queue P=$p->{Commit} ",
2686                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2687             push @todo, $p;
2688         }
2689     }
2690
2691     if (!$sref_S) {
2692         printdebug "quiltify want to smash\n";
2693
2694         my $abbrev = sub {
2695             my $x = $_[0]{Commit};
2696             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2697             return $x;
2698         };
2699         my $reportnot = sub {
2700             my ($notp) = @_;
2701             my $s = $abbrev->($notp);
2702             my $c = $notp->{Child};
2703             $s .= "..".$abbrev->($c) if $c;
2704             $s .= ": ".$notp->{Whynot};
2705             return $s;
2706         };
2707         if ($quilt_mode eq 'linear') {
2708             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2709             foreach my $notp (@nots) {
2710                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2711             }
2712             print STDERR "$us: $_\n" foreach @$failsuggestion;
2713             fail "quilt fixup naive history linearisation failed.\n".
2714  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2715         } elsif ($quilt_mode eq 'smash') {
2716         } elsif ($quilt_mode eq 'auto') {
2717             progress "quilt fixup cannot be linear, smashing...";
2718         } else {
2719             die "$quilt_mode ?";
2720         }
2721
2722         my $time = time;
2723         my $ncommits = 3;
2724         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2725
2726         quiltify_dpkg_commit "auto-$version-$target-$time",
2727             (getfield $clogp, 'Maintainer'),
2728             "Automatically generated patch ($clogp->{Version})\n".
2729             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2730         return;
2731     }
2732
2733     progress "quiltify linearisation planning successful, executing...";
2734
2735     for (my $p = $sref_S;
2736          my $c = $p->{Child};
2737          $p = $p->{Child}) {
2738         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2739         next unless $p->{Nontrivial};
2740
2741         my $cc = $c->{Commit};
2742
2743         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2744         $commitdata =~ m/\n\n/ or die "$c ?";
2745         $commitdata = $`;
2746         my $msg = $'; #';
2747         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2748         my $author = $1;
2749
2750         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2751
2752         my $title = $1;
2753         my $patchname = $title;
2754         $patchname =~ s/[.:]$//;
2755         $patchname =~ y/ A-Z/-a-z/;
2756         $patchname =~ y/-a-z0-9_.+=~//cd;
2757         $patchname =~ s/^\W/x-$&/;
2758         $patchname = substr($patchname,0,40);
2759         my $index;
2760         for ($index='';
2761              stat "debian/patches/$patchname$index";
2762              $index++) { }
2763         $!==ENOENT or die "$patchname$index $!";
2764
2765         runcmd @git, qw(checkout -q), $cc;
2766
2767         # We use the tip's changelog so that dpkg-source doesn't
2768         # produce complaining messages from dpkg-parsechangelog.  None
2769         # of the information dpkg-source gets from the changelog is
2770         # actually relevant - it gets put into the original message
2771         # which dpkg-source provides our stunt editor, and then
2772         # overwritten.
2773         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2774
2775         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2776             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2777
2778         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2779     }
2780
2781     runcmd @git, qw(checkout -q master);
2782 }
2783
2784 sub build_maybe_quilt_fixup () {
2785     my ($format,$fopts) = get_source_format;
2786     return unless madformat $format;
2787     # sigh
2788
2789     check_for_vendor_patches();
2790
2791     my $clogp = parsechangelog();
2792     my $headref = git_rev_parse('HEAD');
2793
2794     prep_ud();
2795     changedir $ud;
2796
2797     my $upstreamversion=$version;
2798     $upstreamversion =~ s/-[^-]*$//;
2799
2800     if ($fopts->{'single-debian-patch'}) {
2801         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2802     } else {
2803         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2804     }
2805
2806     changedir '../../../..';
2807     runcmd_ordryrun_local
2808         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2809 }
2810
2811 sub quilt_fixup_mkwork ($) {
2812     my ($headref) = @_;
2813
2814     mkdir "work" or die $!;
2815     changedir "work";
2816     mktree_in_ud_here();
2817     runcmd @git, qw(reset -q --hard), $headref;
2818 }
2819
2820 sub quilt_fixup_linkorigs ($$) {
2821     my ($upstreamversion, $fn) = @_;
2822     # calls $fn->($leafname);
2823
2824     foreach my $f (<../../../../*>) { #/){
2825         my $b=$f; $b =~ s{.*/}{};
2826         {
2827             local ($debuglevel) = $debuglevel-1;
2828             printdebug "QF linkorigs $b, $f ?\n";
2829         }
2830         next unless is_orig_file $b, srcfn $upstreamversion,'';
2831         printdebug "QF linkorigs $b, $f Y\n";
2832         link_ltarget $f, $b or die "$b $!";
2833         $fn->($b);
2834     }
2835 }
2836
2837 sub quilt_fixup_delete_pc () {
2838     runcmd @git, qw(rm -rqf .pc);
2839     commit_admin "Commit removal of .pc (quilt series tracking data)";
2840 }
2841
2842 sub quilt_fixup_singlepatch ($$$) {
2843     my ($clogp, $headref, $upstreamversion) = @_;
2844
2845     progress "starting quiltify (single-debian-patch)";
2846
2847     # dpkg-source --commit generates new patches even if
2848     # single-debian-patch is in debian/source/options.  In order to
2849     # get it to generate debian/patches/debian-changes, it is
2850     # necessary to build the source package.
2851
2852     quilt_fixup_linkorigs($upstreamversion, sub { });
2853     quilt_fixup_mkwork($headref);
2854
2855     rmtree("debian/patches");
2856
2857     runcmd @dpkgsource, qw(-b .);
2858     chdir "..";
2859     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2860     rename srcfn("$upstreamversion", "/debian/patches"),
2861            "work/debian/patches";
2862
2863     chdir "work";
2864     commit_quilty_patch();
2865
2866
2867 }
2868
2869 sub quilt_fixup_multipatch ($$$) {
2870     my ($clogp, $headref, $upstreamversion) = @_;
2871
2872     progress "starting quiltify (multiple patches, $quilt_mode mode)";
2873
2874     # Our objective is:
2875     #  - honour any existing .pc in case it has any strangeness
2876     #  - determine the git commit corresponding to the tip of
2877     #    the patch stack (if there is one)
2878     #  - if there is such a git commit, convert each subsequent
2879     #    git commit into a quilt patch with dpkg-source --commit
2880     #  - otherwise convert all the differences in the tree into
2881     #    a single git commit
2882     #
2883     # To do this we:
2884
2885     # Our git tree doesn't necessarily contain .pc.  (Some versions of
2886     # dgit would include the .pc in the git tree.)  If there isn't
2887     # one, we need to generate one by unpacking the patches that we
2888     # have.
2889     #
2890     # We first look for a .pc in the git tree.  If there is one, we
2891     # will use it.  (This is not the normal case.)
2892     #
2893     # Otherwise need to regenerate .pc so that dpkg-source --commit
2894     # can work.  We do this as follows:
2895     #     1. Collect all relevant .orig from parent directory
2896     #     2. Generate a debian.tar.gz out of
2897     #         debian/{patches,rules,source/format,source/options}
2898     #     3. Generate a fake .dsc containing just these fields:
2899     #          Format Source Version Files
2900     #     4. Extract the fake .dsc
2901     #        Now the fake .dsc has a .pc directory.
2902     # (In fact we do this in every case, because in future we will
2903     # want to search for a good base commit for generating patches.)
2904     #
2905     # Then we can actually do the dpkg-source --commit
2906     #     1. Make a new working tree with the same object
2907     #        store as our main tree and check out the main
2908     #        tree's HEAD.
2909     #     2. Copy .pc from the fake's extraction, if necessary
2910     #     3. Run dpkg-source --commit
2911     #     4. If the result has changes to debian/, then
2912     #          - git-add them them
2913     #          - git-add .pc if we had a .pc in-tree
2914     #          - git-commit
2915     #     5. If we had a .pc in-tree, delete it, and git-commit
2916     #     6. Back in the main tree, fast forward to the new HEAD
2917
2918     # Another situation we may have to cope with is gbp-style
2919     # patches-unapplied trees.
2920     #
2921     # We would want to detect these, so we know to escape into
2922     # quilt_fixup_gbp.  However, this is in general not possible.
2923     # Consider a package with a one patch which the dgit user reverts
2924     # (with git-revert or the moral equivalent).
2925     #
2926     # That is indistinguishable in contents from a patches-unapplied
2927     # tree.  And looking at the history to distinguish them is not
2928     # useful because the user might have made a confusing-looking git
2929     # history structure (which ought to produce an error if dgit can't
2930     # cope, not a silent reintroduction of an unwanted patch).
2931     #
2932     # So gbp users will have to pass an option.  But we can usually
2933     # detect their failure to do so: if the tree is not a clean
2934     # patches-applied tree, quilt linearisation fails, but the tree
2935     # _is_ a clean patches-unapplied tree, we can suggest that maybe
2936     # they want --quilt=unapplied.
2937     #
2938     # To help detect this, when we are extracting the fake dsc, we
2939     # first extract it with --skip-patches, and then apply the patches
2940     # afterwards with dpkg-source --before-build.  That lets us save a
2941     # tree object corresponding to .origs.
2942
2943     my $fakeversion="$upstreamversion-~~DGITFAKE";
2944
2945     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2946     print $fakedsc <<END or die $!;
2947 Format: 3.0 (quilt)
2948 Source: $package
2949 Version: $fakeversion
2950 Files:
2951 END
2952
2953     my $dscaddfile=sub {
2954         my ($b) = @_;
2955
2956         my $md = new Digest::MD5;
2957
2958         my $fh = new IO::File $b, '<' or die "$b $!";
2959         stat $fh or die $!;
2960         my $size = -s _;
2961
2962         $md->addfile($fh);
2963         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2964     };
2965
2966     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
2967
2968     my @files=qw(debian/source/format debian/rules
2969                  debian/control debian/changelog);
2970     foreach my $maybe (qw(debian/patches debian/source/options
2971                           debian/tests/control)) {
2972         next unless stat_exists "../../../$maybe";
2973         push @files, $maybe;
2974     }
2975
2976     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2977     runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2978
2979     $dscaddfile->($debtar);
2980     close $fakedsc or die $!;
2981
2982     runcmd qw(sh -ec),
2983         'exec dpkg-source --no-check --skip-patches -x fake.dsc >/dev/null';
2984
2985     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2986     rename $fakexdir, "fake" or die "$fakexdir $!";
2987
2988     changedir 'fake';
2989
2990     remove_stray_gits();
2991     mktree_in_ud_here();
2992
2993     rmtree '.pc';
2994
2995     runcmd @git, qw(add -Af .);
2996     my $unapplied=git_write_tree();
2997     printdebug "fake orig tree object $unapplied\n";
2998
2999     ensuredir '.pc';
3000
3001     runcmd qw(sh -ec),
3002         'exec dpkg-source --before-build . >/dev/null';
3003
3004     changedir '..';
3005
3006     quilt_fixup_mkwork($headref);
3007
3008     my $mustdeletepc=0;
3009     if (stat_exists ".pc") {
3010         -d _ or die;
3011         progress "Tree already contains .pc - will use it then delete it.";
3012         $mustdeletepc=1;
3013     } else {
3014         rename '../fake/.pc','.pc' or die $!;
3015     }
3016
3017     changedir '../fake';
3018     rmtree '.pc';
3019     runcmd @git, qw(add -Af .);
3020     my $oldtiptree=git_write_tree();
3021     changedir '../work';
3022
3023
3024     # We calculate some guesswork now about what kind of tree this might
3025     # be.  This is mostly for error reporting.
3026
3027     my $diffbits = {
3028         # H = user's HEAD
3029         # O = orig, without patches applied
3030         # A = "applied", ie orig with H's debian/patches applied
3031         H2O => quiltify_trees_differ($headref,  $unapplied, 1),
3032         H2A => quiltify_trees_differ($headref,  $oldtiptree,1),
3033         O2A => quiltify_trees_differ($unapplied,$oldtiptree,1),
3034     };
3035
3036     my @dl;
3037     foreach my $b (qw(01 02)) {
3038         foreach my $v (qw(H2O O2A H2A)) {
3039             push @dl, ($diffbits->{$v} & $b) ? '##' : '==';
3040         }
3041     }
3042     printdebug "differences \@dl @dl.\n";
3043
3044     progress sprintf
3045 "$us: quilt differences: src:  %s orig %s     gitignores:  %s orig %s\n".
3046 "$us: quilt differences:      HEAD %s o+d/p               HEAD %s o+d/p",
3047                              $dl[0], $dl[1],              $dl[3], $dl[4],
3048                                  $dl[2],                     $dl[5];
3049
3050     my @failsuggestion;
3051     if (!($diffbits->{H2O} & $diffbits->{O2A})) {
3052         push @failsuggestion, "This might be a patches-unapplied branch.";
3053     }  elsif (!($diffbits->{H2A} & $diffbits->{O2A})) {
3054         push @failsuggestion, "This might be a patches-applied branch.";
3055     }
3056     push @failsuggestion, "Maybe you need to specify one of".
3057         " --quilt=gbp --quilt=dpm --quilt=unapplied ?";
3058
3059     if ($quilt_mode =~ m/gbp|dpm|unapplied/) {
3060         quiltify_splitbrain($diffbits);
3061         return;
3062     }
3063
3064     quiltify($clogp,$headref,$oldtiptree,\@failsuggestion);
3065
3066     if (!open P, '>>', ".pc/applied-patches") {
3067         $!==&ENOENT or die $!;
3068     } else {
3069         close P;
3070     }
3071
3072     commit_quilty_patch();
3073
3074     if ($mustdeletepc) {
3075         quilt_fixup_delete_pc();
3076     }
3077 }
3078
3079 sub quilt_fixup_editor () {
3080     my $descfn = $ENV{$fakeeditorenv};
3081     my $editing = $ARGV[$#ARGV];
3082     open I1, '<', $descfn or die "$descfn: $!";
3083     open I2, '<', $editing or die "$editing: $!";
3084     unlink $editing or die "$editing: $!";
3085     open O, '>', $editing or die "$editing: $!";
3086     while (<I1>) { print O or die $!; } I1->error and die $!;
3087     my $copying = 0;
3088     while (<I2>) {
3089         $copying ||= m/^\-\-\- /;
3090         next unless $copying;
3091         print O or die $!;
3092     }
3093     I2->error and die $!;
3094     close O or die $1;
3095     exit 0;
3096 }
3097
3098 #----- other building -----
3099
3100 our $suppress_clean;
3101
3102 sub clean_tree () {
3103     return if $suppress_clean;
3104     if ($cleanmode eq 'dpkg-source') {
3105         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
3106     } elsif ($cleanmode eq 'dpkg-source-d') {
3107         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
3108     } elsif ($cleanmode eq 'git') {
3109         runcmd_ordryrun_local @git, qw(clean -xdf);
3110     } elsif ($cleanmode eq 'git-ff') {
3111         runcmd_ordryrun_local @git, qw(clean -xdff);
3112     } elsif ($cleanmode eq 'check') {
3113         my $leftovers = cmdoutput @git, qw(clean -xdn);
3114         if (length $leftovers) {
3115             print STDERR $leftovers, "\n" or die $!;
3116             fail "tree contains uncommitted files and --clean=check specified";
3117         }
3118     } elsif ($cleanmode eq 'none') {
3119     } else {
3120         die "$cleanmode ?";
3121     }
3122 }
3123
3124 sub cmd_clean () {
3125     badusage "clean takes no additional arguments" if @ARGV;
3126     notpushing();
3127     clean_tree();
3128 }
3129
3130 sub build_prep () {
3131     notpushing();
3132     badusage "-p is not allowed when building" if defined $package;
3133     check_not_dirty();
3134     clean_tree();
3135     my $clogp = parsechangelog();
3136     $isuite = getfield $clogp, 'Distribution';
3137     $package = getfield $clogp, 'Source';
3138     $version = getfield $clogp, 'Version';
3139     build_maybe_quilt_fixup();
3140     if ($rmchanges) {
3141         my $pat = changespat $version;
3142         foreach my $f (glob "$buildproductsdir/$pat") {
3143             if (act_local()) {
3144                 unlink $f or fail "remove old changes file $f: $!";
3145             } else {
3146                 progress "would remove $f";
3147             }
3148         }
3149     }
3150 }
3151
3152 sub changesopts_initial () {
3153     my @opts =@changesopts[1..$#changesopts];
3154 }
3155
3156 sub changesopts_version () {
3157     if (!defined $changes_since_version) {
3158         my @vsns = archive_query('archive_query');
3159         my @quirk = access_quirk();
3160         if ($quirk[0] eq 'backports') {
3161             local $isuite = $quirk[2];
3162             local $csuite;
3163             canonicalise_suite();
3164             push @vsns, archive_query('archive_query');
3165         }
3166         if (@vsns) {
3167             @vsns = map { $_->[0] } @vsns;
3168             @vsns = sort { -version_compare($a, $b) } @vsns;
3169             $changes_since_version = $vsns[0];
3170             progress "changelog will contain changes since $vsns[0]";
3171         } else {
3172             $changes_since_version = '_';
3173             progress "package seems new, not specifying -v<version>";
3174         }
3175     }
3176     if ($changes_since_version ne '_') {
3177         return ("-v$changes_since_version");
3178     } else {
3179         return ();
3180     }
3181 }
3182
3183 sub changesopts () {
3184     return (changesopts_initial(), changesopts_version());
3185 }
3186
3187 sub massage_dbp_args ($;$) {
3188     my ($cmd,$xargs) = @_;
3189     # We need to:
3190     #
3191     #  - if we're going to split the source build out so we can
3192     #    do strange things to it, massage the arguments to dpkg-buildpackage
3193     #    so that the main build doessn't build source (or add an argument
3194     #    to stop it building source by default).
3195     #
3196     #  - add -nc to stop dpkg-source cleaning the source tree,
3197     #    unless we're not doing a split build and want dpkg-source
3198     #    as cleanmode, in which case we can do nothing
3199     #
3200     # return values:
3201     #    0 - source will NOT need to be built separately by caller
3202     #   +1 - source will need to be built separately by caller
3203     #   +2 - source will need to be built separately by caller AND
3204     #        dpkg-buildpackage should not in fact be run at all!
3205     debugcmd '#massaging#', @$cmd if $debuglevel>1;
3206 #print STDERR "MASS0 ",Dumper($cmd, $xargs, $need_split_build_invocation);
3207     if ($cleanmode eq 'dpkg-source' && !$need_split_build_invocation) {
3208         $suppress_clean = 1;
3209         return 0;
3210     }
3211     # -nc has the side effect of specifying -b if nothing else specified
3212     # and some combinations of -S, -b, et al, are errors, rather than
3213     # later simply overriding earlie.  So we need to:
3214     #  - search the command line for these options
3215     #  - pick the last one
3216     #  - perhaps add our own as a default
3217     #  - perhaps adjust it to the corresponding non-source-building version
3218     my $dmode = '-F';
3219     foreach my $l ($cmd, $xargs) {
3220         next unless $l;
3221         @$l = grep { !(m/^-[SgGFABb]$/s and $dmode=$_) } @$l;
3222     }
3223     push @$cmd, '-nc';
3224 #print STDERR "MASS1 ",Dumper($cmd, $xargs, $dmode);
3225     my $r = 0;
3226     if ($need_split_build_invocation) {
3227         $r = $dmode =~ m/[S]/     ? +2 :
3228              $dmode =~ y/gGF/ABb/ ? +1 :
3229              $dmode =~ m/[ABb]/   ?  0 :
3230              die "$dmode ?";
3231     }
3232     push @$cmd, $dmode;
3233 #print STDERR "MASS2 ",Dumper($cmd, $xargs, $r);
3234     return $r;
3235 }
3236
3237 sub cmd_build {
3238     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3239     my $wantsrc = massage_dbp_args \@dbp;
3240     if ($wantsrc > 0) {
3241         build_source();
3242     } else {
3243         build_prep();
3244     }
3245     if ($wantsrc < 2) {
3246         push @dbp, changesopts_version();
3247         runcmd_ordryrun_local @dbp;
3248     }
3249     printdone "build successful\n";
3250 }
3251
3252 sub cmd_gbp_build {
3253     my @dbp = @dpkgbuildpackage;
3254
3255     my $wantsrc = massage_dbp_args \@dbp, \@ARGV;
3256
3257     my @cmd;
3258     if (length executable_on_path('git-buildpackage')) {
3259         @cmd = qw(git-buildpackage);
3260     } else {
3261         @cmd = qw(gbp buildpackage);
3262     }
3263     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3264
3265     if ($wantsrc > 0) {
3266         build_source();
3267     } else {
3268         if (!$suppress_clean) {
3269             push @cmd, '--git-cleaner=true';
3270         }
3271         build_prep();
3272     }
3273     if ($wantsrc < 2) {
3274         unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3275             canonicalise_suite();
3276             push @cmd, "--git-debian-branch=".lbranch();
3277         }
3278         push @cmd, changesopts();
3279         runcmd_ordryrun_local @cmd, @ARGV;
3280     }
3281     printdone "build successful\n";
3282 }
3283 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3284
3285 sub build_source {
3286     if ($cleanmode =~ m/^dpkg-source/) {
3287         # dpkg-source will clean, so we shouldn't
3288         $suppress_clean = 1;
3289     }
3290     build_prep();
3291     $sourcechanges = changespat $version,'source';
3292     if (act_local()) {
3293         unlink "../$sourcechanges" or $!==ENOENT
3294             or fail "remove $sourcechanges: $!";
3295     }
3296     $dscfn = dscfn($version);
3297     if ($cleanmode eq 'dpkg-source') {
3298         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3299                                changesopts();
3300     } elsif ($cleanmode eq 'dpkg-source-d') {
3301         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3302                                changesopts();
3303     } else {
3304         my $pwd = must_getcwd();
3305         my $leafdir = basename $pwd;
3306         changedir "..";
3307         runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
3308         changedir $pwd;
3309         runcmd_ordryrun_local qw(sh -ec),
3310             'exec >$1; shift; exec "$@"','x',
3311             "../$sourcechanges",
3312             @dpkggenchanges, qw(-S), changesopts();
3313     }
3314 }
3315
3316 sub cmd_build_source {
3317     badusage "build-source takes no additional arguments" if @ARGV;
3318     build_source();
3319     printdone "source built, results in $dscfn and $sourcechanges";
3320 }
3321
3322 sub cmd_sbuild {
3323     build_source();
3324     my $pat = changespat $version;
3325     if (!$rmchanges) {
3326         my @unwanted = map { s#^\.\./##; $_; } glob "../$pat";
3327         @unwanted = grep { $_ ne changespat $version,'source' } @unwanted;
3328         fail "changes files other than source matching $pat".
3329             " already present (@unwanted);".
3330             " building would result in ambiguity about the intended results"
3331             if @unwanted;
3332     }
3333     changedir "..";
3334     if (act_local()) {
3335         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3336         stat_exists $sourcechanges
3337             or fail "$sourcechanges (in parent directory): $!";
3338     }
3339     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3340     my @changesfiles = glob $pat;
3341     @changesfiles = sort {
3342         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3343             or $a cmp $b
3344     } @changesfiles;
3345     fail "wrong number of different changes files (@changesfiles)"
3346         unless @changesfiles==2;
3347     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3348     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3349         fail "$l found in binaries changes file $binchanges"
3350             if $l =~ m/\.dsc$/;
3351     }
3352     runcmd_ordryrun_local @mergechanges, @changesfiles;
3353     my $multichanges = changespat $version,'multi';
3354     if (act_local()) {
3355         stat_exists $multichanges or fail "$multichanges: $!";
3356         foreach my $cf (glob $pat) {
3357             next if $cf eq $multichanges;
3358             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3359         }
3360     }
3361     printdone "build successful, results in $multichanges\n" or die $!;
3362 }
3363
3364 sub cmd_quilt_fixup {
3365     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3366     my $clogp = parsechangelog();
3367     $version = getfield $clogp, 'Version';
3368     $package = getfield $clogp, 'Source';
3369     check_not_dirty();
3370     clean_tree();
3371     build_maybe_quilt_fixup();
3372 }
3373
3374 sub cmd_archive_api_query {
3375     badusage "need only 1 subpath argument" unless @ARGV==1;
3376     my ($subpath) = @ARGV;
3377     my @cmd = archive_api_query_cmd($subpath);
3378     debugcmd ">",@cmd;
3379     exec @cmd or fail "exec curl: $!\n";
3380 }
3381
3382 sub cmd_clone_dgit_repos_server {
3383     badusage "need destination argument" unless @ARGV==1;
3384     my ($destdir) = @ARGV;
3385     $package = '_dgit-repos-server';
3386     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3387     debugcmd ">",@cmd;
3388     exec @cmd or fail "exec git clone: $!\n";
3389 }
3390
3391 sub cmd_setup_mergechangelogs {
3392     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3393     setup_mergechangelogs(1);
3394 }
3395
3396 sub cmd_setup_useremail {
3397     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3398     setup_useremail(1);
3399 }
3400
3401 sub cmd_setup_new_tree {
3402     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3403     setup_new_tree();
3404 }
3405
3406 #---------- argument parsing and main program ----------
3407
3408 sub cmd_version {
3409     print "dgit version $our_version\n" or die $!;
3410     exit 0;
3411 }
3412
3413 our (%valopts_long, %valopts_short);
3414 our @rvalopts;
3415
3416 sub defvalopt ($$$$) {
3417     my ($long,$short,$val_re,$how) = @_;
3418     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3419     $valopts_long{$long} = $oi;
3420     $valopts_short{$short} = $oi;
3421     # $how subref should:
3422     #   do whatever assignemnt or thing it likes with $_[0]
3423     #   if the option should not be passed on to remote, @rvalopts=()
3424     # or $how can be a scalar ref, meaning simply assign the value
3425 }
3426
3427 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3428 defvalopt '--distro',        '-d', '.+',      \$idistro;
3429 defvalopt '',                '-k', '.+',      \$keyid;
3430 defvalopt '--existing-package','', '.*',      \$existing_package;
3431 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
3432 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
3433 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
3434
3435 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3436
3437 defvalopt '', '-C', '.+', sub {
3438     ($changesfile) = (@_);
3439     if ($changesfile =~ s#^(.*)/##) {
3440         $buildproductsdir = $1;
3441     }
3442 };
3443
3444 defvalopt '--initiator-tempdir','','.*', sub {
3445     ($initiator_tempdir) = (@_);
3446     $initiator_tempdir =~ m#^/# or
3447         badusage "--initiator-tempdir must be used specify an".
3448         " absolute, not relative, directory."
3449 };
3450
3451 sub parseopts () {
3452     my $om;
3453
3454     if (defined $ENV{'DGIT_SSH'}) {
3455         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3456     } elsif (defined $ENV{'GIT_SSH'}) {
3457         @ssh = ($ENV{'GIT_SSH'});
3458     }
3459
3460     my $oi;
3461     my $val;
3462     my $valopt = sub {
3463         my ($what) = @_;
3464         @rvalopts = ($_);
3465         if (!defined $val) {
3466             badusage "$what needs a value" unless @ARGV;
3467             $val = shift @ARGV;
3468             push @rvalopts, $val;
3469         }
3470         badusage "bad value \`$val' for $what" unless
3471             $val =~ m/^$oi->{Re}$(?!\n)/s;
3472         my $how = $oi->{How};
3473         if (ref($how) eq 'SCALAR') {
3474             $$how = $val;
3475         } else {
3476             $how->($val);
3477         }
3478         push @ropts, @rvalopts;
3479     };
3480
3481     while (@ARGV) {
3482         last unless $ARGV[0] =~ m/^-/;
3483         $_ = shift @ARGV;
3484         last if m/^--?$/;
3485         if (m/^--/) {
3486             if (m/^--dry-run$/) {
3487                 push @ropts, $_;
3488                 $dryrun_level=2;
3489             } elsif (m/^--damp-run$/) {
3490                 push @ropts, $_;
3491                 $dryrun_level=1;
3492             } elsif (m/^--no-sign$/) {
3493                 push @ropts, $_;
3494                 $sign=0;
3495             } elsif (m/^--help$/) {
3496                 cmd_help();
3497             } elsif (m/^--version$/) {
3498                 cmd_version();
3499             } elsif (m/^--new$/) {
3500                 push @ropts, $_;
3501                 $new_package=1;
3502             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3503                      ($om = $opts_opt_map{$1}) &&
3504                      length $om->[0]) {
3505                 push @ropts, $_;
3506                 $om->[0] = $2;
3507             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3508                      !$opts_opt_cmdonly{$1} &&
3509                      ($om = $opts_opt_map{$1})) {
3510                 push @ropts, $_;
3511                 push @$om, $2;
3512             } elsif (m/^--ignore-dirty$/s) {
3513                 push @ropts, $_;
3514                 $ignoredirty = 1;
3515             } elsif (m/^--no-quilt-fixup$/s) {
3516                 push @ropts, $_;
3517                 $quilt_mode = 'nocheck';
3518             } elsif (m/^--no-rm-on-error$/s) {
3519                 push @ropts, $_;
3520                 $rmonerror = 0;
3521             } elsif (m/^--(no-)?rm-old-changes$/s) {
3522                 push @ropts, $_;
3523                 $rmchanges = !$1;
3524             } elsif (m/^--deliberately-($deliberately_re)$/s) {
3525                 push @ropts, $_;
3526                 push @deliberatelies, $&;
3527             } elsif (m/^--always-split-source-build$/s) {
3528                 # undocumented, for testing
3529                 push @ropts, $_;
3530                 $need_split_build_invocation = 1;
3531             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3532                 $val = $2 ? $' : undef; #';
3533                 $valopt->($oi->{Long});
3534             } else {
3535                 badusage "unknown long option \`$_'";
3536             }
3537         } else {
3538             while (m/^-./s) {
3539                 if (s/^-n/-/) {
3540                     push @ropts, $&;
3541                     $dryrun_level=2;
3542                 } elsif (s/^-L/-/) {
3543                     push @ropts, $&;
3544                     $dryrun_level=1;
3545                 } elsif (s/^-h/-/) {
3546                     cmd_help();
3547                 } elsif (s/^-D/-/) {
3548                     push @ropts, $&;
3549                     $debuglevel++;
3550                     enabledebug();
3551                 } elsif (s/^-N/-/) {
3552                     push @ropts, $&;
3553                     $new_package=1;
3554                 } elsif (m/^-m/) {
3555                     push @ropts, $&;
3556                     push @changesopts, $_;
3557                     $_ = '';
3558                 } elsif (s/^-wn$//s) {
3559                     push @ropts, $&;
3560                     $cleanmode = 'none';
3561                 } elsif (s/^-wg$//s) {
3562                     push @ropts, $&;
3563                     $cleanmode = 'git';
3564                 } elsif (s/^-wgf$//s) {
3565                     push @ropts, $&;
3566                     $cleanmode = 'git-ff';
3567                 } elsif (s/^-wd$//s) {
3568                     push @ropts, $&;
3569                     $cleanmode = 'dpkg-source';
3570                 } elsif (s/^-wdd$//s) {
3571                     push @ropts, $&;
3572                     $cleanmode = 'dpkg-source-d';
3573                 } elsif (s/^-wc$//s) {
3574                     push @ropts, $&;
3575                     $cleanmode = 'check';
3576                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3577                     $val = $'; #';
3578                     $val = undef unless length $val;
3579                     $valopt->($oi->{Short});
3580                     $_ = '';
3581                 } else {
3582                     badusage "unknown short option \`$_'";
3583                 }
3584             }
3585         }
3586     }
3587 }
3588
3589 sub finalise_opts_opts () {
3590     foreach my $k (keys %opts_opt_map) {
3591         my $om = $opts_opt_map{$k};
3592
3593         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3594         if (defined $v) {
3595             badcfg "cannot set command for $k"
3596                 unless length $om->[0];
3597             $om->[0] = $v;
3598         }
3599
3600         foreach my $c (access_cfg_cfgs("opts-$k")) {
3601             my $vl = $gitcfg{$c};
3602             printdebug "CL $c ",
3603                 ($vl ? join " ", map { shellquote } @$vl : ""),
3604                 "\n" if $debuglevel >= 4;
3605             next unless $vl;
3606             badcfg "cannot configure options for $k"
3607                 if $opts_opt_cmdonly{$k};
3608             my $insertpos = $opts_cfg_insertpos{$k};
3609             @$om = ( @$om[0..$insertpos-1],
3610                      @$vl,
3611                      @$om[$insertpos..$#$om] );
3612         }
3613     }
3614 }
3615
3616 if ($ENV{$fakeeditorenv}) {
3617     git_slurp_config();
3618     quilt_fixup_editor();
3619 }
3620
3621 parseopts();
3622 git_slurp_config();
3623
3624 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3625 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3626     if $dryrun_level == 1;
3627 if (!@ARGV) {
3628     print STDERR $helpmsg or die $!;
3629     exit 8;
3630 }
3631 my $cmd = shift @ARGV;
3632 $cmd =~ y/-/_/;
3633
3634 if (!defined $rmchanges) {
3635     local $access_forpush;
3636     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3637 }
3638
3639 if (!defined $quilt_mode) {
3640     local $access_forpush;
3641     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3642         // access_cfg('quilt-mode', 'RETURN-UNDEF')
3643         // 'linear';
3644     $quilt_mode =~ m/^($quilt_modes_re)$/
3645         or badcfg "unknown quilt-mode \`$quilt_mode'";
3646     $quilt_mode = $1;
3647 }
3648
3649 if (!defined $cleanmode) {
3650     local $access_forpush;
3651     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3652     $cleanmode //= 'dpkg-source';
3653
3654     badcfg "unknown clean-mode \`$cleanmode'" unless
3655         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3656 }
3657
3658 my $fn = ${*::}{"cmd_$cmd"};
3659 $fn or badusage "unknown operation $cmd";
3660 $fn->();