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