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 $pat = changespat $cversion;
2007         my @cs = glob "$buildproductsdir/$pat";
2008         fail "failed to find unique changes file".
2009             " (looked for $pat in $buildproductsdir);".
2010             " perhaps you need to use dgit -C"
2011             unless @cs==1;
2012         ($changesfile) = @cs;
2013     } else {
2014         $changesfile = "$buildproductsdir/$changesfile";
2015     }
2016
2017     responder_send_file('changes',$changesfile);
2018     responder_send_command("param head $head");
2019     responder_send_command("param csuite $csuite");
2020
2021     if (deliberately_not_fast_forward) {
2022         git_for_each_ref(lrfetchrefs, sub {
2023             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
2024             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
2025             responder_send_command("previously $rrefname=$objid");
2026             $previously{$rrefname} = $objid;
2027         });
2028     }
2029
2030     my $tfn = sub { ".git/dgit/tag$_[0]"; };
2031     my $tagobjfn;
2032
2033     supplementary_message(<<'END');
2034 Push failed, while signing the tag.
2035 You can retry the push, after fixing the problem, if you like.
2036 END
2037     # If we manage to sign but fail to record it anywhere, it's fine.
2038     if ($we_are_responder) {
2039         $tagobjfn = $tfn->('.signed.tmp');
2040         responder_receive_files('signed-tag', $tagobjfn);
2041     } else {
2042         $tagobjfn =
2043             push_mktag($head,$clogp,$tag,
2044                        $dscpath,
2045                        $changesfile,$changesfile,
2046                        $tfn);
2047     }
2048     supplementary_message(<<'END');
2049 Push failed, *after* signing the tag.
2050 If you want to try again, you should use a new version number.
2051 END
2052
2053     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
2054     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
2055     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
2056
2057     supplementary_message(<<'END');
2058 Push failed, while updating the remote git repository - see messages above.
2059 If you want to try again, you should use a new version number.
2060 END
2061     if (!check_for_git()) {
2062         create_remote_git_repo();
2063     }
2064     runcmd_ordryrun @git, qw(push),access_giturl(),
2065         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
2066     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
2067
2068     supplementary_message(<<'END');
2069 Push failed, after updating the remote git repository.
2070 If you want to try again, you must use a new version number.
2071 END
2072     if ($we_are_responder) {
2073         my $dryrunsuffix = act_local() ? "" : ".tmp";
2074         responder_receive_files('signed-dsc-changes',
2075                                 "$dscpath$dryrunsuffix",
2076                                 "$changesfile$dryrunsuffix");
2077     } else {
2078         if (act_local()) {
2079             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
2080         } else {
2081             progress "[new .dsc left in $dscpath.tmp]";
2082         }
2083         sign_changes $changesfile;
2084     }
2085
2086     supplementary_message(<<END);
2087 Push failed, while uploading package(s) to the archive server.
2088 You can retry the upload of exactly these same files with dput of:
2089   $changesfile
2090 If that .changes file is broken, you will need to use a new version
2091 number for your next attempt at the upload.
2092 END
2093     my $host = access_cfg('upload-host','RETURN-UNDEF');
2094     my @hostarg = defined($host) ? ($host,) : ();
2095     runcmd_ordryrun @dput, @hostarg, $changesfile;
2096     printdone "pushed and uploaded $cversion";
2097
2098     supplementary_message('');
2099     responder_send_command("complete");
2100 }
2101
2102 sub cmd_clone {
2103     parseopts();
2104     notpushing();
2105     my $dstdir;
2106     badusage "-p is not allowed with clone; specify as argument instead"
2107         if defined $package;
2108     if (@ARGV==1) {
2109         ($package) = @ARGV;
2110     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
2111         ($package,$isuite) = @ARGV;
2112     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
2113         ($package,$dstdir) = @ARGV;
2114     } elsif (@ARGV==3) {
2115         ($package,$isuite,$dstdir) = @ARGV;
2116     } else {
2117         badusage "incorrect arguments to dgit clone";
2118     }
2119     $dstdir ||= "$package";
2120
2121     if (stat_exists $dstdir) {
2122         fail "$dstdir already exists";
2123     }
2124
2125     my $cwd_remove;
2126     if ($rmonerror && !$dryrun_level) {
2127         $cwd_remove= getcwd();
2128         unshift @end, sub {
2129             return unless defined $cwd_remove;
2130             if (!chdir "$cwd_remove") {
2131                 return if $!==&ENOENT;
2132                 die "chdir $cwd_remove: $!";
2133             }
2134             if (stat $dstdir) {
2135                 rmtree($dstdir) or die "remove $dstdir: $!\n";
2136             } elsif (!grep { $! == $_ }
2137                      (ENOENT, ENOTDIR, EACCES, EPERM, ELOOP)) {
2138             } else {
2139                 print STDERR "check whether to remove $dstdir: $!\n";
2140             }
2141         };
2142     }
2143
2144     clone($dstdir);
2145     $cwd_remove = undef;
2146 }
2147
2148 sub branchsuite () {
2149     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
2150     if ($branch =~ m#$lbranch_re#o) {
2151         return $1;
2152     } else {
2153         return undef;
2154     }
2155 }
2156
2157 sub fetchpullargs () {
2158     notpushing();
2159     if (!defined $package) {
2160         my $sourcep = parsecontrol('debian/control','debian/control');
2161         $package = getfield $sourcep, 'Source';
2162     }
2163     if (@ARGV==0) {
2164 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
2165         if (!$isuite) {
2166             my $clogp = parsechangelog();
2167             $isuite = getfield $clogp, 'Distribution';
2168         }
2169         canonicalise_suite();
2170         progress "fetching from suite $csuite";
2171     } elsif (@ARGV==1) {
2172         ($isuite) = @ARGV;
2173         canonicalise_suite();
2174     } else {
2175         badusage "incorrect arguments to dgit fetch or dgit pull";
2176     }
2177 }
2178
2179 sub cmd_fetch {
2180     parseopts();
2181     fetchpullargs();
2182     fetch();
2183 }
2184
2185 sub cmd_pull {
2186     parseopts();
2187     fetchpullargs();
2188     pull();
2189 }
2190
2191 sub cmd_push {
2192     parseopts();
2193     pushing();
2194     badusage "-p is not allowed with dgit push" if defined $package;
2195     check_not_dirty();
2196     my $clogp = parsechangelog();
2197     $package = getfield $clogp, 'Source';
2198     my $specsuite;
2199     if (@ARGV==0) {
2200     } elsif (@ARGV==1) {
2201         ($specsuite) = (@ARGV);
2202     } else {
2203         badusage "incorrect arguments to dgit push";
2204     }
2205     $isuite = getfield $clogp, 'Distribution';
2206     if ($new_package) {
2207         local ($package) = $existing_package; # this is a hack
2208         canonicalise_suite();
2209     } else {
2210         canonicalise_suite();
2211     }
2212     if (defined $specsuite &&
2213         $specsuite ne $isuite &&
2214         $specsuite ne $csuite) {
2215             fail "dgit push: changelog specifies $isuite ($csuite)".
2216                 " but command line specifies $specsuite";
2217     }
2218     supplementary_message(<<'END');
2219 Push failed, while checking state of the archive.
2220 You can retry the push, after fixing the problem, if you like.
2221 END
2222     if (check_for_git()) {
2223         git_fetch_us();
2224     }
2225     my $forceflag = '';
2226     if (fetch_from_archive()) {
2227         if (is_fast_fwd(lrref(), 'HEAD')) {
2228             # ok
2229         } elsif (deliberately_not_fast_forward) {
2230             $forceflag = '+';
2231         } else {
2232             fail "dgit push: HEAD is not a descendant".
2233                 " of the archive's version.\n".
2234                 "dgit: To overwrite its contents,".
2235                 " use git merge -s ours ".lrref().".\n".
2236                 "dgit: To rewind history, if permitted by the archive,".
2237                 " use --deliberately-not-fast-forward";
2238         }
2239     } else {
2240         $new_package or
2241             fail "package appears to be new in this suite;".
2242                 " if this is intentional, use --new";
2243     }
2244     dopush($forceflag);
2245 }
2246
2247 #---------- remote commands' implementation ----------
2248
2249 sub cmd_remote_push_build_host {
2250     my ($nrargs) = shift @ARGV;
2251     my (@rargs) = @ARGV[0..$nrargs-1];
2252     @ARGV = @ARGV[$nrargs..$#ARGV];
2253     die unless @rargs;
2254     my ($dir,$vsnwant) = @rargs;
2255     # vsnwant is a comma-separated list; we report which we have
2256     # chosen in our ready response (so other end can tell if they
2257     # offered several)
2258     $debugprefix = ' ';
2259     $we_are_responder = 1;
2260     $us .= " (build host)";
2261
2262     pushing();
2263
2264     open PI, "<&STDIN" or die $!;
2265     open STDIN, "/dev/null" or die $!;
2266     open PO, ">&STDOUT" or die $!;
2267     autoflush PO 1;
2268     open STDOUT, ">&STDERR" or die $!;
2269     autoflush STDOUT 1;
2270
2271     $vsnwant //= 1;
2272     ($protovsn) = grep {
2273         $vsnwant =~ m{^(?:.*,)?$_(?:,.*)?$}
2274     } @rpushprotovsn_support;
2275
2276     fail "build host has dgit rpush protocol versions ".
2277         (join ",", @rpushprotovsn_support).
2278         " but invocation host has $vsnwant"
2279         unless defined $protovsn;
2280
2281     responder_send_command("dgit-remote-push-ready $protovsn");
2282
2283     changedir $dir;
2284     &cmd_push;
2285 }
2286
2287 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2288 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2289 #     a good error message)
2290
2291 our $i_tmp;
2292
2293 sub i_cleanup {
2294     local ($@, $?);
2295     my $report = i_child_report();
2296     if (defined $report) {
2297         printdebug "($report)\n";
2298     } elsif ($i_child_pid) {
2299         printdebug "(killing build host child $i_child_pid)\n";
2300         kill 15, $i_child_pid;
2301     }
2302     if (defined $i_tmp && !defined $initiator_tempdir) {
2303         changedir "/";
2304         eval { rmtree $i_tmp; };
2305     }
2306 }
2307
2308 END { i_cleanup(); }
2309
2310 sub i_method {
2311     my ($base,$selector,@args) = @_;
2312     $selector =~ s/\-/_/g;
2313     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2314 }
2315
2316 sub cmd_rpush {
2317     pushing();
2318     my $host = nextarg;
2319     my $dir;
2320     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2321         $host = $1;
2322         $dir = $'; #';
2323     } else {
2324         $dir = nextarg;
2325     }
2326     $dir =~ s{^-}{./-};
2327     my @rargs = ($dir);
2328     push @rargs, join ",", @rpushprotovsn_support;
2329     my @rdgit;
2330     push @rdgit, @dgit;
2331     push @rdgit, @ropts;
2332     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2333     push @rdgit, @ARGV;
2334     my @cmd = (@ssh, $host, shellquote @rdgit);
2335     debugcmd "+",@cmd;
2336
2337     if (defined $initiator_tempdir) {
2338         rmtree $initiator_tempdir;
2339         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2340         $i_tmp = $initiator_tempdir;
2341     } else {
2342         $i_tmp = tempdir();
2343     }
2344     $i_child_pid = open2(\*RO, \*RI, @cmd);
2345     changedir $i_tmp;
2346     ($protovsn) = initiator_expect { m/^dgit-remote-push-ready (\S+)/ };
2347     die "$protovsn ?" unless grep { $_ eq $protovsn } @rpushprotovsn_support;
2348     $supplementary_message = '' unless $protovsn >= 3;
2349     for (;;) {
2350         my ($icmd,$iargs) = initiator_expect {
2351             m/^(\S+)(?: (.*))?$/;
2352             ($1,$2);
2353         };
2354         i_method "i_resp", $icmd, $iargs;
2355     }
2356 }
2357
2358 sub i_resp_progress ($) {
2359     my ($rhs) = @_;
2360     my $msg = protocol_read_bytes \*RO, $rhs;
2361     progress $msg;
2362 }
2363
2364 sub i_resp_supplementary_message ($) {
2365     my ($rhs) = @_;
2366     $supplementary_message = protocol_read_bytes \*RO, $rhs;
2367 }
2368
2369 sub i_resp_complete {
2370     my $pid = $i_child_pid;
2371     $i_child_pid = undef; # prevents killing some other process with same pid
2372     printdebug "waiting for build host child $pid...\n";
2373     my $got = waitpid $pid, 0;
2374     die $! unless $got == $pid;
2375     die "build host child failed $?" if $?;
2376
2377     i_cleanup();
2378     printdebug "all done\n";
2379     exit 0;
2380 }
2381
2382 sub i_resp_file ($) {
2383     my ($keyword) = @_;
2384     my $localname = i_method "i_localname", $keyword;
2385     my $localpath = "$i_tmp/$localname";
2386     stat_exists $localpath and
2387         badproto \*RO, "file $keyword ($localpath) twice";
2388     protocol_receive_file \*RO, $localpath;
2389     i_method "i_file", $keyword;
2390 }
2391
2392 our %i_param;
2393
2394 sub i_resp_param ($) {
2395     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2396     $i_param{$1} = $2;
2397 }
2398
2399 sub i_resp_previously ($) {
2400     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2401         or badproto \*RO, "bad previously spec";
2402     my $r = system qw(git check-ref-format), $1;
2403     die "bad previously ref spec ($r)" if $r;
2404     $previously{$1} = $2;
2405 }
2406
2407 our %i_wanted;
2408
2409 sub i_resp_want ($) {
2410     my ($keyword) = @_;
2411     die "$keyword ?" if $i_wanted{$keyword}++;
2412     my @localpaths = i_method "i_want", $keyword;
2413     printdebug "[[  $keyword @localpaths\n";
2414     foreach my $localpath (@localpaths) {
2415         protocol_send_file \*RI, $localpath;
2416     }
2417     print RI "files-end\n" or die $!;
2418 }
2419
2420 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2421
2422 sub i_localname_parsed_changelog {
2423     return "remote-changelog.822";
2424 }
2425 sub i_file_parsed_changelog {
2426     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2427         push_parse_changelog "$i_tmp/remote-changelog.822";
2428     die if $i_dscfn =~ m#/|^\W#;
2429 }
2430
2431 sub i_localname_dsc {
2432     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2433     return $i_dscfn;
2434 }
2435 sub i_file_dsc { }
2436
2437 sub i_localname_changes {
2438     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2439     $i_changesfn = $i_dscfn;
2440     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2441     return $i_changesfn;
2442 }
2443 sub i_file_changes { }
2444
2445 sub i_want_signed_tag {
2446     printdebug Dumper(\%i_param, $i_dscfn);
2447     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2448         && defined $i_param{'csuite'}
2449         or badproto \*RO, "premature desire for signed-tag";
2450     my $head = $i_param{'head'};
2451     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2452
2453     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2454     $csuite = $&;
2455     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2456
2457     my $tagobjfn =
2458         push_mktag $head, $i_clogp, $i_tag,
2459             $i_dscfn,
2460             $i_changesfn, 'remote changes',
2461             sub { "tag$_[0]"; };
2462
2463     return $tagobjfn;
2464 }
2465
2466 sub i_want_signed_dsc_changes {
2467     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2468     sign_changes $i_changesfn;
2469     return ($i_dscfn, $i_changesfn);
2470 }
2471
2472 #---------- building etc. ----------
2473
2474 our $version;
2475 our $sourcechanges;
2476 our $dscfn;
2477
2478 #----- `3.0 (quilt)' handling -----
2479
2480 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2481
2482 sub quiltify_dpkg_commit ($$$;$) {
2483     my ($patchname,$author,$msg, $xinfo) = @_;
2484     $xinfo //= '';
2485
2486     mkpath '.git/dgit';
2487     my $descfn = ".git/dgit/quilt-description.tmp";
2488     open O, '>', $descfn or die "$descfn: $!";
2489     $msg =~ s/\s+$//g;
2490     $msg =~ s/\n/\n /g;
2491     $msg =~ s/^\s+$/ ./mg;
2492     print O <<END or die $!;
2493 Description: $msg
2494 Author: $author
2495 $xinfo
2496 ---
2497
2498 END
2499     close O or die $!;
2500
2501     {
2502         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2503         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2504         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2505         runcmd @dpkgsource, qw(--commit .), $patchname;
2506     }
2507 }
2508
2509 sub quiltify_trees_differ ($$) {
2510     my ($x,$y) = @_;
2511     # returns 1 iff the two tree objects differ other than in debian/
2512     local $/=undef;
2513     my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2514     my $diffs= cmdoutput @cmd;
2515     foreach my $f (split /\0/, $diffs) {
2516         next if $f eq 'debian';
2517         return 1;
2518     }
2519     return 0;
2520 }
2521
2522 sub quiltify_tree_sentinelfiles ($) {
2523     # lists the `sentinel' files present in the tree
2524     my ($x) = @_;
2525     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2526         qw(-- debian/rules debian/control);
2527     $r =~ s/\n/,/g;
2528     return $r;
2529 }
2530
2531 sub quiltify ($$) {
2532     my ($clogp,$target) = @_;
2533
2534     # Quilt patchification algorithm
2535     #
2536     # We search backwards through the history of the main tree's HEAD
2537     # (T) looking for a start commit S whose tree object is identical
2538     # to to the patch tip tree (ie the tree corresponding to the
2539     # current dpkg-committed patch series).  For these purposes
2540     # `identical' disregards anything in debian/ - this wrinkle is
2541     # necessary because dpkg-source treates debian/ specially.
2542     #
2543     # We can only traverse edges where at most one of the ancestors'
2544     # trees differs (in changes outside in debian/).  And we cannot
2545     # handle edges which change .pc/ or debian/patches.  To avoid
2546     # going down a rathole we avoid traversing edges which introduce
2547     # debian/rules or debian/control.  And we set a limit on the
2548     # number of edges we are willing to look at.
2549     #
2550     # If we succeed, we walk forwards again.  For each traversed edge
2551     # PC (with P parent, C child) (starting with P=S and ending with
2552     # C=T) to we do this:
2553     #  - git checkout C
2554     #  - dpkg-source --commit with a patch name and message derived from C
2555     # After traversing PT, we git commit the changes which
2556     # should be contained within debian/patches.
2557
2558     changedir '../fake';
2559     remove_stray_gits();
2560     mktree_in_ud_here();
2561     rmtree '.pc';
2562     runcmd @git, qw(add -Af .);
2563     my $oldtiptree=git_write_tree();
2564     changedir '../work';
2565
2566     # The search for the path S..T is breadth-first.  We maintain a
2567     # todo list containing search nodes.  A search node identifies a
2568     # commit, and looks something like this:
2569     #  $p = {
2570     #      Commit => $git_commit_id,
2571     #      Child => $c,                          # or undef if P=T
2572     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2573     #      Nontrivial => true iff $p..$c has relevant changes
2574     #  };
2575
2576     my @todo;
2577     my @nots;
2578     my $sref_S;
2579     my $max_work=100;
2580     my %considered; # saves being exponential on some weird graphs
2581
2582     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2583
2584     my $not = sub {
2585         my ($search,$whynot) = @_;
2586         printdebug " search NOT $search->{Commit} $whynot\n";
2587         $search->{Whynot} = $whynot;
2588         push @nots, $search;
2589         no warnings qw(exiting);
2590         next;
2591     };
2592
2593     push @todo, {
2594         Commit => $target,
2595     };
2596
2597     while (@todo) {
2598         my $c = shift @todo;
2599         next if $considered{$c->{Commit}}++;
2600
2601         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2602
2603         printdebug "quiltify investigate $c->{Commit}\n";
2604
2605         # are we done?
2606         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2607             printdebug " search finished hooray!\n";
2608             $sref_S = $c;
2609             last;
2610         }
2611
2612         if ($quilt_mode eq 'nofix') {
2613             fail "quilt fixup required but quilt mode is \`nofix'\n".
2614                 "HEAD commit $c->{Commit} differs from tree implied by ".
2615                 " debian/patches (tree object $oldtiptree)";
2616         }
2617         if ($quilt_mode eq 'smash') {
2618             printdebug " search quitting smash\n";
2619             last;
2620         }
2621
2622         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2623         $not->($c, "has $c_sentinels not $t_sentinels")
2624             if $c_sentinels ne $t_sentinels;
2625
2626         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2627         $commitdata =~ m/\n\n/;
2628         $commitdata =~ $`;
2629         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2630         @parents = map { { Commit => $_, Child => $c } } @parents;
2631
2632         $not->($c, "root commit") if !@parents;
2633
2634         foreach my $p (@parents) {
2635             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2636         }
2637         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2638         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2639
2640         foreach my $p (@parents) {
2641             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2642
2643             my @cmd= (@git, qw(diff-tree -r --name-only),
2644                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2645             my $patchstackchange = cmdoutput @cmd;
2646             if (length $patchstackchange) {
2647                 $patchstackchange =~ s/\n/,/g;
2648                 $not->($p, "changed $patchstackchange");
2649             }
2650
2651             printdebug " search queue P=$p->{Commit} ",
2652                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2653             push @todo, $p;
2654         }
2655     }
2656
2657     if (!$sref_S) {
2658         printdebug "quiltify want to smash\n";
2659
2660         my $abbrev = sub {
2661             my $x = $_[0]{Commit};
2662             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2663             return $x;
2664         };
2665         my $reportnot = sub {
2666             my ($notp) = @_;
2667             my $s = $abbrev->($notp);
2668             my $c = $notp->{Child};
2669             $s .= "..".$abbrev->($c) if $c;
2670             $s .= ": ".$notp->{Whynot};
2671             return $s;
2672         };
2673         if ($quilt_mode eq 'linear') {
2674             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2675             foreach my $notp (@nots) {
2676                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2677             }
2678             fail "quilt fixup naive history linearisation failed.\n".
2679  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2680         } elsif ($quilt_mode eq 'smash') {
2681         } elsif ($quilt_mode eq 'auto') {
2682             progress "quilt fixup cannot be linear, smashing...";
2683         } else {
2684             die "$quilt_mode ?";
2685         }
2686
2687         my $time = time;
2688         my $ncommits = 3;
2689         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2690
2691         quiltify_dpkg_commit "auto-$version-$target-$time",
2692             (getfield $clogp, 'Maintainer'),
2693             "Automatically generated patch ($clogp->{Version})\n".
2694             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2695         return;
2696     }
2697
2698     progress "quiltify linearisation planning successful, executing...";
2699
2700     for (my $p = $sref_S;
2701          my $c = $p->{Child};
2702          $p = $p->{Child}) {
2703         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2704         next unless $p->{Nontrivial};
2705
2706         my $cc = $c->{Commit};
2707
2708         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2709         $commitdata =~ m/\n\n/ or die "$c ?";
2710         $commitdata = $`;
2711         my $msg = $'; #';
2712         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2713         my $author = $1;
2714
2715         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2716
2717         my $title = $1;
2718         my $patchname = $title;
2719         $patchname =~ s/[.:]$//;
2720         $patchname =~ y/ A-Z/-a-z/;
2721         $patchname =~ y/-a-z0-9_.+=~//cd;
2722         $patchname =~ s/^\W/x-$&/;
2723         $patchname = substr($patchname,0,40);
2724         my $index;
2725         for ($index='';
2726              stat "debian/patches/$patchname$index";
2727              $index++) { }
2728         $!==ENOENT or die "$patchname$index $!";
2729
2730         runcmd @git, qw(checkout -q), $cc;
2731
2732         # We use the tip's changelog so that dpkg-source doesn't
2733         # produce complaining messages from dpkg-parsechangelog.  None
2734         # of the information dpkg-source gets from the changelog is
2735         # actually relevant - it gets put into the original message
2736         # which dpkg-source provides our stunt editor, and then
2737         # overwritten.
2738         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2739
2740         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2741             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2742
2743         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2744     }
2745
2746     runcmd @git, qw(checkout -q master);
2747 }
2748
2749 sub build_maybe_quilt_fixup () {
2750     my ($format,$fopts) = get_source_format;
2751     return unless madformat $format;
2752     # sigh
2753
2754     check_for_vendor_patches();
2755
2756     my $clogp = parsechangelog();
2757     my $headref = git_rev_parse('HEAD');
2758
2759     prep_ud();
2760     changedir $ud;
2761
2762     my $upstreamversion=$version;
2763     $upstreamversion =~ s/-[^-]*$//;
2764
2765     if ($fopts->{'single-debian-patch'}) {
2766         quilt_fixup_singlepatch($clogp, $headref, $upstreamversion);
2767     } else {
2768         quilt_fixup_multipatch($clogp, $headref, $upstreamversion);
2769     }
2770
2771     changedir '../../../..';
2772     runcmd_ordryrun_local
2773         @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2774 }
2775
2776 sub quilt_fixup_mkwork ($) {
2777     my ($headref) = @_;
2778
2779     mkdir "work" or die $!;
2780     changedir "work";
2781     mktree_in_ud_here();
2782     runcmd @git, qw(reset --hard), $headref;
2783 }
2784
2785 sub quilt_fixup_linkorigs ($$) {
2786     my ($upstreamversion, $fn) = @_;
2787     # calls $fn->($leafname);
2788
2789     foreach my $f (<../../../../*>) { #/){
2790         my $b=$f; $b =~ s{.*/}{};
2791         {
2792             local ($debuglevel) = $debuglevel-1;
2793             printdebug "QF linkorigs $b, $f ?\n";
2794         }
2795         next unless is_orig_file $b, srcfn $upstreamversion,'';
2796         printdebug "QF linkorigs $b, $f Y\n";
2797         link_ltarget $f, $b or die "$b $!";
2798         $fn->($b);
2799     }
2800 }
2801
2802 sub quilt_fixup_delete_pc () {
2803     runcmd @git, qw(rm -rqf .pc);
2804     commit_admin "Commit removal of .pc (quilt series tracking data)";
2805 }
2806
2807 sub quilt_fixup_singlepatch ($$$) {
2808     my ($clogp, $headref, $upstreamversion) = @_;
2809
2810     progress "starting quiltify (single-debian-patch)";
2811
2812     # dpkg-source --commit generates new patches even if
2813     # single-debian-patch is in debian/source/options.  In order to
2814     # get it to generate debian/patches/debian-changes, it is
2815     # necessary to build the source package.
2816
2817     quilt_fixup_linkorigs($upstreamversion, sub { });
2818     quilt_fixup_mkwork($headref);
2819
2820     rmtree("debian/patches");
2821
2822     runcmd @dpkgsource, qw(-b .);
2823     chdir "..";
2824     runcmd @dpkgsource, qw(-x), (srcfn $version, ".dsc");
2825     rename srcfn("$upstreamversion", "/debian/patches"),
2826            "work/debian/patches";
2827
2828     chdir "work";
2829     commit_quilty_patch();
2830
2831
2832 }
2833
2834 sub quilt_fixup_multipatch ($$$) {
2835     my ($clogp, $headref, $upstreamversion) = @_;
2836
2837     progress "starting quiltify (multiple patches, $quilt_mode mode)";
2838
2839     # Our objective is:
2840     #  - honour any existing .pc in case it has any strangeness
2841     #  - determine the git commit corresponding to the tip of
2842     #    the patch stack (if there is one)
2843     #  - if there is such a git commit, convert each subsequent
2844     #    git commit into a quilt patch with dpkg-source --commit
2845     #  - otherwise convert all the differences in the tree into
2846     #    a single git commit
2847     #
2848     # To do this we:
2849
2850     # Our git tree doesn't necessarily contain .pc.  (Some versions of
2851     # dgit would include the .pc in the git tree.)  If there isn't
2852     # one, we need to generate one by unpacking the patches that we
2853     # have.
2854     #
2855     # We first look for a .pc in the git tree.  If there is one, we
2856     # will use it.  (This is not the normal case.)
2857     #
2858     # Otherwise need to regenerate .pc so that dpkg-source --commit
2859     # can work.  We do this as follows:
2860     #     1. Collect all relevant .orig from parent directory
2861     #     2. Generate a debian.tar.gz out of
2862     #         debian/{patches,rules,source/format,source/options}
2863     #     3. Generate a fake .dsc containing just these fields:
2864     #          Format Source Version Files
2865     #     4. Extract the fake .dsc
2866     #        Now the fake .dsc has a .pc directory.
2867     # (In fact we do this in every case, because in future we will
2868     # want to search for a good base commit for generating patches.)
2869     #
2870     # Then we can actually do the dpkg-source --commit
2871     #     1. Make a new working tree with the same object
2872     #        store as our main tree and check out the main
2873     #        tree's HEAD.
2874     #     2. Copy .pc from the fake's extraction, if necessary
2875     #     3. Run dpkg-source --commit
2876     #     4. If the result has changes to debian/, then
2877     #          - git-add them them
2878     #          - git-add .pc if we had a .pc in-tree
2879     #          - git-commit
2880     #     5. If we had a .pc in-tree, delete it, and git-commit
2881     #     6. Back in the main tree, fast forward to the new HEAD
2882
2883     my $fakeversion="$upstreamversion-~~DGITFAKE";
2884
2885     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2886     print $fakedsc <<END or die $!;
2887 Format: 3.0 (quilt)
2888 Source: $package
2889 Version: $fakeversion
2890 Files:
2891 END
2892
2893     my $dscaddfile=sub {
2894         my ($b) = @_;
2895
2896         my $md = new Digest::MD5;
2897
2898         my $fh = new IO::File $b, '<' or die "$b $!";
2899         stat $fh or die $!;
2900         my $size = -s _;
2901
2902         $md->addfile($fh);
2903         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2904     };
2905
2906     quilt_fixup_linkorigs($upstreamversion, $dscaddfile);
2907
2908     my @files=qw(debian/source/format debian/rules);
2909     foreach my $maybe (qw(debian/patches debian/source/options)) {
2910         next unless stat_exists "../../../$maybe";
2911         push @files, $maybe;
2912     }
2913
2914     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2915     runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2916
2917     $dscaddfile->($debtar);
2918     close $fakedsc or die $!;
2919
2920     runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2921
2922     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2923     rename $fakexdir, "fake" or die "$fakexdir $!";
2924
2925     quilt_fixup_mkwork($headref);
2926
2927     my $mustdeletepc=0;
2928     if (stat_exists ".pc") {
2929         -d _ or die;
2930         progress "Tree already contains .pc - will use it then delete it.";
2931         $mustdeletepc=1;
2932     } else {
2933         rename '../fake/.pc','.pc' or die $!;
2934     }
2935
2936     quiltify($clogp,$headref);
2937
2938     if (!open P, '>>', ".pc/applied-patches") {
2939         $!==&ENOENT or die $!;
2940     } else {
2941         close P;
2942     }
2943
2944     commit_quilty_patch();
2945
2946     if ($mustdeletepc) {
2947         quilt_fixup_delete_pc();
2948     }
2949 }
2950
2951 sub quilt_fixup_editor () {
2952     my $descfn = $ENV{$fakeeditorenv};
2953     my $editing = $ARGV[$#ARGV];
2954     open I1, '<', $descfn or die "$descfn: $!";
2955     open I2, '<', $editing or die "$editing: $!";
2956     unlink $editing or die "$editing: $!";
2957     open O, '>', $editing or die "$editing: $!";
2958     while (<I1>) { print O or die $!; } I1->error and die $!;
2959     my $copying = 0;
2960     while (<I2>) {
2961         $copying ||= m/^\-\-\- /;
2962         next unless $copying;
2963         print O or die $!;
2964     }
2965     I2->error and die $!;
2966     close O or die $1;
2967     exit 0;
2968 }
2969
2970 #----- other building -----
2971
2972 our $suppress_clean;
2973
2974 sub clean_tree () {
2975     return if $suppress_clean;
2976     if ($cleanmode eq 'dpkg-source') {
2977         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2978     } elsif ($cleanmode eq 'dpkg-source-d') {
2979         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2980     } elsif ($cleanmode eq 'git') {
2981         runcmd_ordryrun_local @git, qw(clean -xdf);
2982     } elsif ($cleanmode eq 'git-ff') {
2983         runcmd_ordryrun_local @git, qw(clean -xdff);
2984     } elsif ($cleanmode eq 'check') {
2985         my $leftovers = cmdoutput @git, qw(clean -xdn);
2986         if (length $leftovers) {
2987             print STDERR $leftovers, "\n" or die $!;
2988             fail "tree contains uncommitted files and --clean=check specified";
2989         }
2990     } elsif ($cleanmode eq 'none') {
2991     } else {
2992         die "$cleanmode ?";
2993     }
2994 }
2995
2996 sub cmd_clean () {
2997     badusage "clean takes no additional arguments" if @ARGV;
2998     notpushing();
2999     clean_tree();
3000 }
3001
3002 sub build_prep () {
3003     notpushing();
3004     badusage "-p is not allowed when building" if defined $package;
3005     check_not_dirty();
3006     clean_tree();
3007     my $clogp = parsechangelog();
3008     $isuite = getfield $clogp, 'Distribution';
3009     $package = getfield $clogp, 'Source';
3010     $version = getfield $clogp, 'Version';
3011     build_maybe_quilt_fixup();
3012     if ($rmchanges) {
3013         my $pat = changespat $version;
3014         foreach my $f (glob "$buildproductsdir/$pat") {
3015             if (act_local()) {
3016                 unlink $f or fail "remove old changes file $f: $!";
3017             } else {
3018                 progress "would remove $f";
3019             }
3020         }
3021     }
3022 }
3023
3024 sub changesopts_initial () {
3025     my @opts =@changesopts[1..$#changesopts];
3026 }
3027
3028 sub changesopts_version () {
3029     if (!defined $changes_since_version) {
3030         my @vsns = archive_query('archive_query');
3031         my @quirk = access_quirk();
3032         if ($quirk[0] eq 'backports') {
3033             local $isuite = $quirk[2];
3034             local $csuite;
3035             canonicalise_suite();
3036             push @vsns, archive_query('archive_query');
3037         }
3038         if (@vsns) {
3039             @vsns = map { $_->[0] } @vsns;
3040             @vsns = sort { -version_compare($a, $b) } @vsns;
3041             $changes_since_version = $vsns[0];
3042             progress "changelog will contain changes since $vsns[0]";
3043         } else {
3044             $changes_since_version = '_';
3045             progress "package seems new, not specifying -v<version>";
3046         }
3047     }
3048     if ($changes_since_version ne '_') {
3049         return ("-v$changes_since_version");
3050     } else {
3051         return ();
3052     }
3053 }
3054
3055 sub changesopts () {
3056     return (changesopts_initial(), changesopts_version());
3057 }
3058
3059 sub massage_dbp_args ($;$) {
3060     my ($cmd,$xargs) = @_;
3061     if ($cleanmode eq 'dpkg-source') {
3062         $suppress_clean = 1;
3063         return;
3064     }
3065     debugcmd '#massaging#', @$cmd if $debuglevel>1;
3066     my @newcmd = shift @$cmd;
3067     # -nc has the side effect of specifying -b if nothing else specified
3068     push @newcmd, '-nc';
3069     # and some combinations of -S, -b, et al, are errors, rather than
3070     # later simply overriding earlier
3071     push @newcmd, '-F' unless grep { m/^-[bBASFgG]$/ } (@$cmd, @$xargs);
3072     push @newcmd, @$cmd;
3073     @$cmd = @newcmd;
3074 }
3075
3076 sub cmd_build {
3077     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts_initial(), @ARGV);
3078     massage_dbp_args \@dbp;
3079     build_prep();
3080     push @dbp, changesopts_version();
3081     runcmd_ordryrun_local @dbp;
3082     printdone "build successful\n";
3083 }
3084
3085 sub cmd_gbp_build {
3086     my @dbp = @dpkgbuildpackage;
3087     massage_dbp_args \@dbp, \@ARGV;
3088
3089     my @cmd;
3090     if (length executable_on_path('git-buildpackage')) {
3091         @cmd = qw(git-buildpackage);
3092     } else {
3093         @cmd = qw(gbp buildpackage);
3094     }
3095     push @cmd, (qw(-us -uc --git-no-sign-tags), "--git-builder=@dbp");
3096
3097     if ($cleanmode eq 'dpkg-source') {
3098         $suppress_clean = 1;
3099     } else {
3100         push @cmd, '--git-cleaner=true';
3101     }
3102     build_prep();
3103     unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
3104         canonicalise_suite();
3105         push @cmd, "--git-debian-branch=".lbranch();
3106     }
3107     push @cmd, changesopts();
3108     runcmd_ordryrun_local @cmd, @ARGV;
3109     printdone "build successful\n";
3110 }
3111 sub cmd_git_build { cmd_gbp_build(); } # compatibility with <= 1.0
3112
3113 sub build_source {
3114     if ($cleanmode =~ m/^dpkg-source/) {
3115         # dpkg-source will clean, so we shouldn't
3116         $suppress_clean = 1;
3117     }
3118     build_prep();
3119     $sourcechanges = changespat $version,'source';
3120     if (act_local()) {
3121         unlink "../$sourcechanges" or $!==ENOENT
3122             or fail "remove $sourcechanges: $!";
3123     }
3124     $dscfn = dscfn($version);
3125     if ($cleanmode eq 'dpkg-source') {
3126         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S),
3127                                changesopts();
3128     } elsif ($cleanmode eq 'dpkg-source-d') {
3129         runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc -S -d),
3130                                changesopts();
3131     } else {
3132         my $pwd = must_getcwd();
3133         my $leafdir = basename $pwd;
3134         changedir "..";
3135         runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
3136         changedir $pwd;
3137         runcmd_ordryrun_local qw(sh -ec),
3138             'exec >$1; shift; exec "$@"','x',
3139             "../$sourcechanges",
3140             @dpkggenchanges, qw(-S), changesopts();
3141     }
3142 }
3143
3144 sub cmd_build_source {
3145     badusage "build-source takes no additional arguments" if @ARGV;
3146     build_source();
3147     printdone "source built, results in $dscfn and $sourcechanges";
3148 }
3149
3150 sub cmd_sbuild {
3151     build_source();
3152     changedir "..";
3153     my $pat = changespat $version;
3154     if (act_local()) {
3155         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
3156         stat_exists $sourcechanges
3157             or fail "$sourcechanges (in parent directory): $!";
3158         foreach my $cf (glob $pat) {
3159             next if $cf eq $sourcechanges;
3160             unlink $cf or fail "remove $cf: $!";
3161         }
3162     }
3163     runcmd_ordryrun_local @sbuild, qw(-d), $isuite, @ARGV, $dscfn;
3164     my @changesfiles = glob $pat;
3165     @changesfiles = sort {
3166         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
3167             or $a cmp $b
3168     } @changesfiles;
3169     fail "wrong number of different changes files (@changesfiles)"
3170         unless @changesfiles==2;
3171     my $binchanges = parsecontrol($changesfiles[1], "binary changes file");
3172     foreach my $l (split /\n/, getfield $binchanges, 'Files') {
3173         fail "$l found in binaries changes file $binchanges"
3174             if $l =~ m/\.dsc$/;
3175     }
3176     runcmd_ordryrun_local @mergechanges, @changesfiles;
3177     my $multichanges = changespat $version,'multi';
3178     if (act_local()) {
3179         stat_exists $multichanges or fail "$multichanges: $!";
3180         foreach my $cf (glob $pat) {
3181             next if $cf eq $multichanges;
3182             rename "$cf", "$cf.inmulti" or fail "$cf\{,.inmulti}: $!";
3183         }
3184     }
3185     printdone "build successful, results in $multichanges\n" or die $!;
3186 }
3187
3188 sub cmd_quilt_fixup {
3189     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
3190     my $clogp = parsechangelog();
3191     $version = getfield $clogp, 'Version';
3192     $package = getfield $clogp, 'Source';
3193     check_not_dirty();
3194     clean_tree();
3195     build_maybe_quilt_fixup();
3196 }
3197
3198 sub cmd_archive_api_query {
3199     badusage "need only 1 subpath argument" unless @ARGV==1;
3200     my ($subpath) = @ARGV;
3201     my @cmd = archive_api_query_cmd($subpath);
3202     debugcmd ">",@cmd;
3203     exec @cmd or fail "exec curl: $!\n";
3204 }
3205
3206 sub cmd_clone_dgit_repos_server {
3207     badusage "need destination argument" unless @ARGV==1;
3208     my ($destdir) = @ARGV;
3209     $package = '_dgit-repos-server';
3210     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
3211     debugcmd ">",@cmd;
3212     exec @cmd or fail "exec git clone: $!\n";
3213 }
3214
3215 sub cmd_setup_mergechangelogs {
3216     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3217     setup_mergechangelogs(1);
3218 }
3219
3220 sub cmd_setup_useremail {
3221     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
3222     setup_useremail(1);
3223 }
3224
3225 sub cmd_setup_new_tree {
3226     badusage "no arguments allowed to dgit setup-tree" if @ARGV;
3227     setup_new_tree();
3228 }
3229
3230 #---------- argument parsing and main program ----------
3231
3232 sub cmd_version {
3233     print "dgit version $our_version\n" or die $!;
3234     exit 0;
3235 }
3236
3237 our (%valopts_long, %valopts_short);
3238 our @rvalopts;
3239
3240 sub defvalopt ($$$$) {
3241     my ($long,$short,$val_re,$how) = @_;
3242     my $oi = { Long => $long, Short => $short, Re => $val_re, How => $how };
3243     $valopts_long{$long} = $oi;
3244     $valopts_short{$short} = $oi;
3245     # $how subref should:
3246     #   do whatever assignemnt or thing it likes with $_[0]
3247     #   if the option should not be passed on to remote, @rvalopts=()
3248     # or $how can be a scalar ref, meaning simply assign the value
3249 }
3250
3251 defvalopt '--since-version', '-v', '[^_]+|_', \$changes_since_version;
3252 defvalopt '--distro',        '-d', '.+',      \$idistro;
3253 defvalopt '',                '-k', '.+',      \$keyid;
3254 defvalopt '--existing-package','', '.*',      \$existing_package;
3255 defvalopt '--build-products-dir','','.*',     \$buildproductsdir;
3256 defvalopt '--clean',       '', $cleanmode_re, \$cleanmode;
3257 defvalopt '--quilt',     '', $quilt_modes_re, \$quilt_mode;
3258
3259 defvalopt '', '-c', '.*=.*', sub { push @git, '-c', @_; };
3260
3261 defvalopt '', '-C', '.+', sub {
3262     ($changesfile) = (@_);
3263     if ($changesfile =~ s#^(.*)/##) {
3264         $buildproductsdir = $1;
3265     }
3266 };
3267
3268 defvalopt '--initiator-tempdir','','.*', sub {
3269     ($initiator_tempdir) = (@_);
3270     $initiator_tempdir =~ m#^/# or
3271         badusage "--initiator-tempdir must be used specify an".
3272         " absolute, not relative, directory."
3273 };
3274
3275 sub parseopts () {
3276     my $om;
3277
3278     if (defined $ENV{'DGIT_SSH'}) {
3279         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
3280     } elsif (defined $ENV{'GIT_SSH'}) {
3281         @ssh = ($ENV{'GIT_SSH'});
3282     }
3283
3284     my $oi;
3285     my $val;
3286     my $valopt = sub {
3287         my ($what) = @_;
3288         @rvalopts = ($_);
3289         if (!defined $val) {
3290             badusage "$what needs a value" unless @ARGV;
3291             $val = shift @ARGV;
3292             push @rvalopts, $val;
3293         }
3294         badusage "bad value \`$val' for $what" unless
3295             $val =~ m/^$oi->{Re}$(?!\n)/s;
3296         my $how = $oi->{How};
3297         if (ref($how) eq 'SCALAR') {
3298             $$how = $val;
3299         } else {
3300             $how->($val);
3301         }
3302         push @ropts, @rvalopts;
3303     };
3304
3305     while (@ARGV) {
3306         last unless $ARGV[0] =~ m/^-/;
3307         $_ = shift @ARGV;
3308         last if m/^--?$/;
3309         if (m/^--/) {
3310             if (m/^--dry-run$/) {
3311                 push @ropts, $_;
3312                 $dryrun_level=2;
3313             } elsif (m/^--damp-run$/) {
3314                 push @ropts, $_;
3315                 $dryrun_level=1;
3316             } elsif (m/^--no-sign$/) {
3317                 push @ropts, $_;
3318                 $sign=0;
3319             } elsif (m/^--help$/) {
3320                 cmd_help();
3321             } elsif (m/^--version$/) {
3322                 cmd_version();
3323             } elsif (m/^--new$/) {
3324                 push @ropts, $_;
3325                 $new_package=1;
3326             } elsif (m/^--([-0-9a-z]+)=(.+)/s &&
3327                      ($om = $opts_opt_map{$1}) &&
3328                      length $om->[0]) {
3329                 push @ropts, $_;
3330                 $om->[0] = $2;
3331             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
3332                      !$opts_opt_cmdonly{$1} &&
3333                      ($om = $opts_opt_map{$1})) {
3334                 push @ropts, $_;
3335                 push @$om, $2;
3336             } elsif (m/^--ignore-dirty$/s) {
3337                 push @ropts, $_;
3338                 $ignoredirty = 1;
3339             } elsif (m/^--no-quilt-fixup$/s) {
3340                 push @ropts, $_;
3341                 $quilt_mode = 'nocheck';
3342             } elsif (m/^--no-rm-on-error$/s) {
3343                 push @ropts, $_;
3344                 $rmonerror = 0;
3345             } elsif (m/^--(no-)?rm-old-changes$/s) {
3346                 push @ropts, $_;
3347                 $rmchanges = !$1;
3348             } elsif (m/^--deliberately-($deliberately_re)$/s) {
3349                 push @ropts, $_;
3350                 push @deliberatelies, $&;
3351             } elsif (m/^(--[-0-9a-z]+)(=|$)/ && ($oi = $valopts_long{$1})) {
3352                 $val = $2 ? $' : undef; #';
3353                 $valopt->($oi->{Long});
3354             } else {
3355                 badusage "unknown long option \`$_'";
3356             }
3357         } else {
3358             while (m/^-./s) {
3359                 if (s/^-n/-/) {
3360                     push @ropts, $&;
3361                     $dryrun_level=2;
3362                 } elsif (s/^-L/-/) {
3363                     push @ropts, $&;
3364                     $dryrun_level=1;
3365                 } elsif (s/^-h/-/) {
3366                     cmd_help();
3367                 } elsif (s/^-D/-/) {
3368                     push @ropts, $&;
3369                     $debuglevel++;
3370                     enabledebug();
3371                 } elsif (s/^-N/-/) {
3372                     push @ropts, $&;
3373                     $new_package=1;
3374                 } elsif (m/^-m/) {
3375                     push @ropts, $&;
3376                     push @changesopts, $_;
3377                     $_ = '';
3378                 } elsif (s/^-wn$//s) {
3379                     push @ropts, $&;
3380                     $cleanmode = 'none';
3381                 } elsif (s/^-wg$//s) {
3382                     push @ropts, $&;
3383                     $cleanmode = 'git';
3384                 } elsif (s/^-wgf$//s) {
3385                     push @ropts, $&;
3386                     $cleanmode = 'git-ff';
3387                 } elsif (s/^-wd$//s) {
3388                     push @ropts, $&;
3389                     $cleanmode = 'dpkg-source';
3390                 } elsif (s/^-wdd$//s) {
3391                     push @ropts, $&;
3392                     $cleanmode = 'dpkg-source-d';
3393                 } elsif (s/^-wc$//s) {
3394                     push @ropts, $&;
3395                     $cleanmode = 'check';
3396                 } elsif (m/^-[a-zA-Z]/ && ($oi = $valopts_short{$&})) {
3397                     $val = $'; #';
3398                     $val = undef unless length $val;
3399                     $valopt->($oi->{Short});
3400                     $_ = '';
3401                 } else {
3402                     badusage "unknown short option \`$_'";
3403                 }
3404             }
3405         }
3406     }
3407 }
3408
3409 sub finalise_opts_opts () {
3410     foreach my $k (keys %opts_opt_map) {
3411         my $om = $opts_opt_map{$k};
3412
3413         my $v = access_cfg("cmd-$k", 'RETURN-UNDEF');
3414         if (defined $v) {
3415             badcfg "cannot set command for $k"
3416                 unless length $om->[0];
3417             $om->[0] = $v;
3418         }
3419
3420         foreach my $c (access_cfg_cfgs("opts-$k")) {
3421             my $vl = $gitcfg{$c};
3422             printdebug "CL $c ",
3423                 ($vl ? join " ", map { shellquote } @$vl : ""),
3424                 "\n" if $debuglevel >= 4;
3425             next unless $vl;
3426             badcfg "cannot configure options for $k"
3427                 if $opts_opt_cmdonly{$k};
3428             my $insertpos = $opts_cfg_insertpos{$k};
3429             @$om = ( @$om[0..$insertpos-1],
3430                      @$vl,
3431                      @$om[$insertpos..$#$om] );
3432         }
3433     }
3434 }
3435
3436 if ($ENV{$fakeeditorenv}) {
3437     git_slurp_config();
3438     quilt_fixup_editor();
3439 }
3440
3441 parseopts();
3442 git_slurp_config();
3443
3444 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3445 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3446     if $dryrun_level == 1;
3447 if (!@ARGV) {
3448     print STDERR $helpmsg or die $!;
3449     exit 8;
3450 }
3451 my $cmd = shift @ARGV;
3452 $cmd =~ y/-/_/;
3453
3454 if (!defined $rmchanges) {
3455     local $access_forpush;
3456     $rmchanges = access_cfg_bool(0, 'rm-old-changes');
3457 }
3458
3459 if (!defined $quilt_mode) {
3460     local $access_forpush;
3461     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3462         // access_cfg('quilt-mode', 'RETURN-UNDEF')
3463         // 'linear';
3464     $quilt_mode =~ m/^($quilt_modes_re)$/
3465         or badcfg "unknown quilt-mode \`$quilt_mode'";
3466     $quilt_mode = $1;
3467 }
3468
3469 if (!defined $cleanmode) {
3470     local $access_forpush;
3471     $cleanmode = access_cfg('clean-mode', 'RETURN-UNDEF');
3472     $cleanmode //= 'dpkg-source';
3473
3474     badcfg "unknown clean-mode \`$cleanmode'" unless
3475         $cleanmode =~ m/^($cleanmode_re)$(?!\n)/s;
3476 }
3477
3478 my $fn = ${*::}{"cmd_$cmd"};
3479 $fn or badusage "unknown operation $cmd";
3480 $fn->();