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