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