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