dgit

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