dgit

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