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