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