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