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 remove_stray_gits () {
1143     my @gitscmd = qw(find -name .git -prune -print0);
1144     debugcmd "|",@gitscmd;
1145     open GITS, "-|", @gitscmd or failedcmd @gitscmd;
1146     {
1147         local $/="\0";
1148         while (<GITS>) {
1149             chomp or die;
1150             print STDERR "$us: warning: removing from source package: ",
1151                 (messagequote $_), "\n";
1152             rmtree $_;
1153         }
1154     }
1155     $!=0; $?=0; close GITS or failedcmd @gitscmd;
1156 }
1157
1158 sub mktree_in_ud_from_only_subdir () {
1159     # changes into the subdir
1160     my (@dirs) = <*/.>;
1161     die unless @dirs==1;
1162     $dirs[0] =~ m#^([^/]+)/\.$# or die;
1163     my $dir = $1;
1164     changedir $dir;
1165
1166     remove_stray_gits();
1167     mktree_in_ud_here();
1168     my $format=get_source_format();
1169     if (madformat($format)) {
1170         rmtree '.pc';
1171     }
1172     runcmd @git, qw(add -Af);
1173     my $tree=git_write_tree();
1174     return ($tree,$dir);
1175 }
1176
1177 sub dsc_files_info () {
1178     foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
1179                        ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
1180                        ['Files',           'Digest::MD5', 'new()']) {
1181         my ($fname, $module, $method) = @$csumi;
1182         my $field = $dsc->{$fname};
1183         next unless defined $field;
1184         eval "use $module; 1;" or die $@;
1185         my @out;
1186         foreach (split /\n/, $field) {
1187             next unless m/\S/;
1188             m/^(\w+) (\d+) (\S+)$/ or
1189                 fail "could not parse .dsc $fname line \`$_'";
1190             my $digester = eval "$module"."->$method;" or die $@;
1191             push @out, {
1192                 Hash => $1,
1193                 Bytes => $2,
1194                 Filename => $3,
1195                 Digester => $digester,
1196             };
1197         }
1198         return @out;
1199     }
1200     fail "missing any supported Checksums-* or Files field in ".
1201         $dsc->get_option('name');
1202 }
1203
1204 sub dsc_files () {
1205     map { $_->{Filename} } dsc_files_info();
1206 }
1207
1208 sub is_orig_file ($;$) {
1209     local ($_) = $_[0];
1210     my $base = $_[1];
1211     m/\.orig(?:-\w+)?\.tar\.\w+$/ or return 0;
1212     defined $base or return 1;
1213     return $` eq $base;
1214 }
1215
1216 sub make_commit ($) {
1217     my ($file) = @_;
1218     return cmdoutput @git, qw(hash-object -w -t commit), $file;
1219 }
1220
1221 sub clogp_authline ($) {
1222     my ($clogp) = @_;
1223     my $author = getfield $clogp, 'Maintainer';
1224     $author =~ s#,.*##ms;
1225     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
1226     my $authline = "$author $date";
1227     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
1228         fail "unexpected commit author line format \`$authline'".
1229         " (was generated from changelog Maintainer field)";
1230     return $authline;
1231 }
1232
1233 sub vendor_patches_distro ($$) {
1234     my ($checkdistro, $what) = @_;
1235     return unless defined $checkdistro;
1236
1237     my $series = "debian/patches/\L$checkdistro\E.series";
1238     printdebug "checking for vendor-specific $series ($what)\n";
1239
1240     if (!open SERIES, "<", $series) {
1241         die "$series $!" unless $!==ENOENT;
1242         return;
1243     }
1244     while (<SERIES>) {
1245         next unless m/\S/;
1246         next if m/^\s+\#/;
1247
1248         print STDERR <<END;
1249
1250 Unfortunately, this source package uses a feature of dpkg-source where
1251 the same source package unpacks to different source code on different
1252 distros.  dgit cannot safely operate on such packages on affected
1253 distros, because the meaning of source packages is not stable.
1254
1255 Please ask the distro/maintainer to remove the distro-specific series
1256 files and use a different technique (if necessary, uploading actually
1257 different packages, if different distros are supposed to have
1258 different code).
1259
1260 END
1261         fail "Found active distro-specific series file for".
1262             " $checkdistro ($what): $series, cannot continue";
1263     }
1264     die "$series $!" if SERIES->error;
1265     close SERIES;
1266 }
1267
1268 sub check_for_vendor_patches () {
1269     # This dpkg-source feature doesn't seem to be documented anywhere!
1270     # But it can be found in the changelog (reformatted):
1271
1272     #   commit  4fa01b70df1dc4458daee306cfa1f987b69da58c
1273     #   Author: Raphael Hertzog <hertzog@debian.org>
1274     #   Date: Sun  Oct  3  09:36:48  2010 +0200
1275
1276     #   dpkg-source: correctly create .pc/.quilt_series with alternate
1277     #   series files
1278     #
1279     #   If you have debian/patches/ubuntu.series and you were
1280     #   unpacking the source package on ubuntu, quilt was still
1281     #   directed to debian/patches/series instead of
1282     #   debian/patches/ubuntu.series.
1283     #
1284     #   debian/changelog                        |    3 +++
1285     #   scripts/Dpkg/Source/Package/V3/quilt.pm |    4 +++-
1286     #   2 files changed, 6 insertions(+), 1 deletion(-)
1287
1288     use Dpkg::Vendor;
1289     vendor_patches_distro($ENV{DEB_VENDOR}, "DEB_VENDOR");
1290     vendor_patches_distro(Dpkg::Vendor::get_current_vendor(),
1291                          "Dpkg::Vendor \`current vendor'");
1292     vendor_patches_distro(access_basedistro(),
1293                           "distro being accessed");
1294 }
1295
1296 sub generate_commit_from_dsc () {
1297     prep_ud();
1298     changedir $ud;
1299
1300     foreach my $fi (dsc_files_info()) {
1301         my $f = $fi->{Filename};
1302         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
1303
1304         link "../../../$f", $f
1305             or $!==&ENOENT
1306             or die "$f $!";
1307
1308         complete_file_from_dsc('.', $fi);
1309
1310         if (is_orig_file($f)) {
1311             link $f, "../../../../$f"
1312                 or $!==&EEXIST
1313                 or die "$f $!";
1314         }
1315     }
1316
1317     my $dscfn = "$package.dsc";
1318
1319     open D, ">", $dscfn or die "$dscfn: $!";
1320     print D $dscdata or die "$dscfn: $!";
1321     close D or die "$dscfn: $!";
1322     my @cmd = qw(dpkg-source);
1323     push @cmd, '--no-check' if $dsc_checked;
1324     push @cmd, qw(-x --), $dscfn;
1325     runcmd @cmd;
1326
1327     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1328     check_for_vendor_patches() if madformat($dsc->{format});
1329     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
1330     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
1331     my $authline = clogp_authline $clogp;
1332     my $changes = getfield $clogp, 'Changes';
1333     open C, ">../commit.tmp" or die $!;
1334     print C <<END or die $!;
1335 tree $tree
1336 author $authline
1337 committer $authline
1338
1339 $changes
1340
1341 # imported from the archive
1342 END
1343     close C or die $!;
1344     my $outputhash = make_commit qw(../commit.tmp);
1345     my $cversion = getfield $clogp, 'Version';
1346     progress "synthesised git commit from .dsc $cversion";
1347     if ($lastpush_hash) {
1348         runcmd @git, qw(reset --hard), $lastpush_hash;
1349         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
1350         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
1351         my $oversion = getfield $oldclogp, 'Version';
1352         my $vcmp =
1353             version_compare($oversion, $cversion);
1354         if ($vcmp < 0) {
1355             # git upload/ is earlier vsn than archive, use archive
1356             open C, ">../commit2.tmp" or die $!;
1357             print C <<END or die $!;
1358 tree $tree
1359 parent $lastpush_hash
1360 parent $outputhash
1361 author $authline
1362 committer $authline
1363
1364 Record $package ($cversion) in archive suite $csuite
1365 END
1366             $outputhash = make_commit qw(../commit2.tmp);
1367         } elsif ($vcmp > 0) {
1368             print STDERR <<END or die $!;
1369
1370 Version actually in archive:    $cversion (older)
1371 Last allegedly pushed/uploaded: $oversion (newer or same)
1372 $later_warning_msg
1373 END
1374             $outputhash = $lastpush_hash;
1375         } else {
1376             $outputhash = $lastpush_hash;
1377         }
1378     }
1379     changedir '../../../..';
1380     runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
1381             'DGIT_ARCHIVE', $outputhash;
1382     cmdoutput @git, qw(log -n2), $outputhash;
1383     # ... gives git a chance to complain if our commit is malformed
1384     rmtree($ud);
1385     return $outputhash;
1386 }
1387
1388 sub complete_file_from_dsc ($$) {
1389     our ($dstdir, $fi) = @_;
1390     # Ensures that we have, in $dir, the file $fi, with the correct
1391     # contents.  (Downloading it from alongside $dscurl if necessary.)
1392
1393     my $f = $fi->{Filename};
1394     my $tf = "$dstdir/$f";
1395     my $downloaded = 0;
1396
1397     if (stat_exists $tf) {
1398         progress "using existing $f";
1399     } else {
1400         my $furl = $dscurl;
1401         $furl =~ s{/[^/]+$}{};
1402         $furl .= "/$f";
1403         die "$f ?" unless $f =~ m/^${package}_/;
1404         die "$f ?" if $f =~ m#/#;
1405         runcmd_ordryrun_local @curl,qw(-o),$tf,'--',"$furl";
1406         next if !act_local();
1407         $downloaded = 1;
1408     }
1409
1410     open F, "<", "$tf" or die "$tf: $!";
1411     $fi->{Digester}->reset();
1412     $fi->{Digester}->addfile(*F);
1413     F->error and die $!;
1414     my $got = $fi->{Digester}->hexdigest();
1415     $got eq $fi->{Hash} or
1416         fail "file $f has hash $got but .dsc".
1417             " demands hash $fi->{Hash} ".
1418             ($downloaded ? "(got wrong file from archive!)"
1419              : "(perhaps you should delete this file?)");
1420 }
1421
1422 sub ensure_we_have_orig () {
1423     foreach my $fi (dsc_files_info()) {
1424         my $f = $fi->{Filename};
1425         next unless is_orig_file($f);
1426         complete_file_from_dsc('..', $fi);
1427     }
1428 }
1429
1430 sub git_fetch_us () {
1431     my @specs = (fetchspec());
1432     push @specs,
1433         map { "+refs/$_/*:".lrfetchrefs."/$_/*" }
1434         qw(tags heads);
1435     runcmd_ordryrun_local @git, qw(fetch -p -n -q), access_giturl(), @specs;
1436
1437     my %here;
1438     my $tagpat = debiantag('*',access_basedistro);
1439
1440     git_for_each_ref("refs/tags/".$tagpat, sub {
1441         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1442         printdebug "currently $fullrefname=$objid\n";
1443         $here{$fullrefname} = $objid;
1444     });
1445     git_for_each_ref(lrfetchrefs."/tags/".$tagpat, sub {
1446         my ($objid,$objtype,$fullrefname,$reftail) = @_;
1447         my $lref = "refs".substr($fullrefname, length lrfetchrefs);
1448         printdebug "offered $lref=$objid\n";
1449         if (!defined $here{$lref}) {
1450             my @upd = (@git, qw(update-ref), $lref, $objid, '');
1451             runcmd_ordryrun_local @upd;
1452         } elsif ($here{$lref} eq $objid) {
1453         } else {
1454             print STDERR \
1455                 "Not updateting $lref from $here{$lref} to $objid.\n";
1456         }
1457     });
1458 }
1459
1460 sub fetch_from_archive () {
1461     # ensures that lrref() is what is actually in the archive,
1462     #  one way or another
1463     get_archive_dsc();
1464
1465     if ($dsc) {
1466         foreach my $field (@ourdscfield) {
1467             $dsc_hash = $dsc->{$field};
1468             last if defined $dsc_hash;
1469         }
1470         if (defined $dsc_hash) {
1471             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
1472             $dsc_hash = $&;
1473             progress "last upload to archive specified git hash";
1474         } else {
1475             progress "last upload to archive has NO git hash";
1476         }
1477     } else {
1478         progress "no version available from the archive";
1479     }
1480
1481     $lastpush_hash = git_get_ref(lrref());
1482     printdebug "previous reference hash=$lastpush_hash\n";
1483     my $hash;
1484     if (defined $dsc_hash) {
1485         fail "missing remote git history even though dsc has hash -".
1486             " could not find ref ".lrref().
1487             " (should have been fetched from ".access_giturl()."#".rrref().")"
1488             unless $lastpush_hash;
1489         $hash = $dsc_hash;
1490         ensure_we_have_orig();
1491         if ($dsc_hash eq $lastpush_hash) {
1492         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
1493             print STDERR <<END or die $!;
1494
1495 Git commit in archive is behind the last version allegedly pushed/uploaded.
1496 Commit referred to by archive:  $dsc_hash
1497 Last allegedly pushed/uploaded: $lastpush_hash
1498 $later_warning_msg
1499 END
1500             $hash = $lastpush_hash;
1501         } else {
1502             fail "git head (".lrref()."=$lastpush_hash) is not a ".
1503                 "descendant of archive's .dsc hash ($dsc_hash)";
1504         }
1505     } elsif ($dsc) {
1506         $hash = generate_commit_from_dsc();
1507     } elsif ($lastpush_hash) {
1508         # only in git, not in the archive yet
1509         $hash = $lastpush_hash;
1510         print STDERR <<END or die $!;
1511
1512 Package not found in the archive, but has allegedly been pushed using dgit.
1513 $later_warning_msg
1514 END
1515     } else {
1516         printdebug "nothing found!\n";
1517         if (defined $skew_warning_vsn) {
1518             print STDERR <<END or die $!;
1519
1520 Warning: relevant archive skew detected.
1521 Archive allegedly contains $skew_warning_vsn
1522 But we were not able to obtain any version from the archive or git.
1523
1524 END
1525         }
1526         return 0;
1527     }
1528     printdebug "current hash=$hash\n";
1529     if ($lastpush_hash) {
1530         fail "not fast forward on last upload branch!".
1531             " (archive's version left in DGIT_ARCHIVE)"
1532             unless is_fast_fwd($lastpush_hash, $hash);
1533     }
1534     if (defined $skew_warning_vsn) {
1535         mkpath '.git/dgit';
1536         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
1537         my $clogf = ".git/dgit/changelog.tmp";
1538         runcmd shell_cmd "exec >$clogf",
1539             @git, qw(cat-file blob), "$hash:debian/changelog";
1540         my $gotclogp = parsechangelog("-l$clogf");
1541         my $got_vsn = getfield $gotclogp, 'Version';
1542         printdebug "SKEW CHECK GOT $got_vsn\n";
1543         if (version_compare($got_vsn, $skew_warning_vsn) < 0) {
1544             print STDERR <<END or die $!;
1545
1546 Warning: archive skew detected.  Using the available version:
1547 Archive allegedly contains    $skew_warning_vsn
1548 We were able to obtain only   $got_vsn
1549
1550 END
1551         }
1552     }
1553     if ($lastpush_hash ne $hash) {
1554         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1555         if (act_local()) {
1556             cmdoutput @upd_cmd;
1557         } else {
1558             dryrun_report @upd_cmd;
1559         }
1560     }
1561     return 1;
1562 }
1563
1564 sub set_local_git_config ($$) {
1565     my ($k, $v) = @_;
1566     runcmd @git, qw(config), $k, $v;
1567 }
1568
1569 sub setup_mergechangelogs () {
1570     my $driver = 'dpkg-mergechangelogs';
1571     my $cb = "merge.$driver";
1572     my $attrs = '.git/info/attributes';
1573     ensuredir '.git/info';
1574
1575     open NATTRS, ">", "$attrs.new" or die "$attrs.new $!";
1576     if (!open ATTRS, "<", $attrs) {
1577         $!==ENOENT or die "$attrs: $!";
1578     } else {
1579         while (<ATTRS>) {
1580             chomp;
1581             next if m{^debian/changelog\s};
1582             print NATTRS $_, "\n" or die $!;
1583         }
1584         ATTRS->error and die $!;
1585         close ATTRS;
1586     }
1587     print NATTRS "debian/changelog merge=$driver\n" or die $!;
1588     close NATTRS;
1589
1590     set_local_git_config "$cb.name", 'debian/changelog merge driver';
1591     set_local_git_config "$cb.driver", 'dpkg-mergechangelogs -m %O %A %B %A';
1592
1593     rename "$attrs.new", "$attrs" or die "$attrs: $!";
1594 }
1595
1596 sub clone ($) {
1597     my ($dstdir) = @_;
1598     canonicalise_suite();
1599     badusage "dry run makes no sense with clone" unless act_local();
1600     my $hasgit = check_for_git();
1601     mkdir $dstdir or die "$dstdir $!";
1602     changedir $dstdir;
1603     runcmd @git, qw(init -q);
1604     my $giturl = access_giturl(1);
1605     if (defined $giturl) {
1606         set_local_git_config "remote.$remotename.fetch", fetchspec();
1607         open H, "> .git/HEAD" or die $!;
1608         print H "ref: ".lref()."\n" or die $!;
1609         close H or die $!;
1610         runcmd @git, qw(remote add), 'origin', $giturl;
1611     }
1612     if ($hasgit) {
1613         progress "fetching existing git history";
1614         git_fetch_us();
1615         runcmd_ordryrun_local @git, qw(fetch origin);
1616     } else {
1617         progress "starting new git history";
1618     }
1619     fetch_from_archive() or no_such_package;
1620     my $vcsgiturl = $dsc->{'Vcs-Git'};
1621     if (length $vcsgiturl) {
1622         $vcsgiturl =~ s/\s+-b\s+\S+//g;
1623         runcmd @git, qw(remote add vcs-git), $vcsgiturl;
1624     }
1625     setup_mergechangelogs();
1626     runcmd @git, qw(reset --hard), lrref();
1627     printdone "ready for work in $dstdir";
1628 }
1629
1630 sub fetch () {
1631     if (check_for_git()) {
1632         git_fetch_us();
1633     }
1634     fetch_from_archive() or no_such_package();
1635     printdone "fetched into ".lrref();
1636 }
1637
1638 sub pull () {
1639     fetch();
1640     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1641         lrref();
1642     printdone "fetched to ".lrref()." and merged into HEAD";
1643 }
1644
1645 sub check_not_dirty () {
1646     return if $ignoredirty;
1647     my @cmd = (@git, qw(diff --quiet HEAD));
1648     debugcmd "+",@cmd;
1649     $!=0; $?=0; system @cmd;
1650     return if !$! && !$?;
1651     if (!$! && $?==256) {
1652         fail "working tree is dirty (does not match HEAD)";
1653     } else {
1654         failedcmd @cmd;
1655     }
1656 }
1657
1658 sub commit_admin ($) {
1659     my ($m) = @_;
1660     progress "$m";
1661     runcmd_ordryrun_local @git, qw(commit -m), $m;
1662 }
1663
1664 sub commit_quilty_patch () {
1665     my $output = cmdoutput @git, qw(status --porcelain);
1666     my %adds;
1667     foreach my $l (split /\n/, $output) {
1668         next unless $l =~ m/\S/;
1669         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1670             $adds{$1}++;
1671         }
1672     }
1673     delete $adds{'.pc'}; # if there wasn't one before, don't add it
1674     if (!%adds) {
1675         progress "nothing quilty to commit, ok.";
1676         return;
1677     }
1678     runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1679     commit_admin "Commit Debian 3.0 (quilt) metadata";
1680 }
1681
1682 sub get_source_format () {
1683     if (!open F, "debian/source/format") {
1684         die $! unless $!==&ENOENT;
1685         return '';
1686     }
1687     $_ = <F>;
1688     F->error and die $!;
1689     chomp;
1690     return $_;
1691 }
1692
1693 sub madformat ($) {
1694     my ($format) = @_;
1695     return 0 unless $format eq '3.0 (quilt)';
1696     if ($quilt_mode eq 'nocheck') {
1697         progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1698         return 0;
1699     }
1700     progress "Format \`$format', checking/updating patch stack";
1701     return 1;
1702 }
1703
1704 sub push_parse_changelog ($) {
1705     my ($clogpfn) = @_;
1706
1707     my $clogp = Dpkg::Control::Hash->new();
1708     $clogp->load($clogpfn) or die;
1709
1710     $package = getfield $clogp, 'Source';
1711     my $cversion = getfield $clogp, 'Version';
1712     my $tag = debiantag($cversion, access_basedistro);
1713     runcmd @git, qw(check-ref-format), $tag;
1714
1715     my $dscfn = dscfn($cversion);
1716
1717     return ($clogp, $cversion, $tag, $dscfn);
1718 }
1719
1720 sub push_parse_dsc ($$$) {
1721     my ($dscfn,$dscfnwhat, $cversion) = @_;
1722     $dsc = parsecontrol($dscfn,$dscfnwhat);
1723     my $dversion = getfield $dsc, 'Version';
1724     my $dscpackage = getfield $dsc, 'Source';
1725     ($dscpackage eq $package && $dversion eq $cversion) or
1726         fail "$dscfn is for $dscpackage $dversion".
1727             " but debian/changelog is for $package $cversion";
1728 }
1729
1730 sub push_mktag ($$$$$$$) {
1731     my ($head,$clogp,$tag,
1732         $dscfn,
1733         $changesfile,$changesfilewhat,
1734         $tfn) = @_;
1735
1736     $dsc->{$ourdscfield[0]} = $head;
1737     $dsc->save("$dscfn.tmp") or die $!;
1738
1739     my $changes = parsecontrol($changesfile,$changesfilewhat);
1740     foreach my $field (qw(Source Distribution Version)) {
1741         $changes->{$field} eq $clogp->{$field} or
1742             fail "changes field $field \`$changes->{$field}'".
1743                 " does not match changelog \`$clogp->{$field}'";
1744     }
1745
1746     my $cversion = getfield $clogp, 'Version';
1747     my $clogsuite = getfield $clogp, 'Distribution';
1748
1749     # We make the git tag by hand because (a) that makes it easier
1750     # to control the "tagger" (b) we can do remote signing
1751     my $authline = clogp_authline $clogp;
1752     my $delibs = join(" ", "",@deliberatelies);
1753     my $declaredistro = access_basedistro();
1754     open TO, '>', $tfn->('.tmp') or die $!;
1755     print TO <<END or die $!;
1756 object $head
1757 type commit
1758 tag $tag
1759 tagger $authline
1760
1761 $package release $cversion for $clogsuite ($csuite) [dgit]
1762 [dgit distro=$declaredistro$delibs]
1763 END
1764     foreach my $ref (sort keys %previously) {
1765                     print TO <<END or die $!;
1766 [dgit previously:$ref=$previously{$ref}]
1767 END
1768     }
1769
1770     close TO or die $!;
1771
1772     my $tagobjfn = $tfn->('.tmp');
1773     if ($sign) {
1774         if (!defined $keyid) {
1775             $keyid = access_cfg('keyid','RETURN-UNDEF');
1776         }
1777         unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1778         my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1779         push @sign_cmd, qw(-u),$keyid if defined $keyid;
1780         push @sign_cmd, $tfn->('.tmp');
1781         runcmd_ordryrun @sign_cmd;
1782         if (act_scary()) {
1783             $tagobjfn = $tfn->('.signed.tmp');
1784             runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1785                 $tfn->('.tmp'), $tfn->('.tmp.asc');
1786         }
1787     }
1788
1789     return ($tagobjfn);
1790 }
1791
1792 sub sign_changes ($) {
1793     my ($changesfile) = @_;
1794     if ($sign) {
1795         my @debsign_cmd = @debsign;
1796         push @debsign_cmd, "-k$keyid" if defined $keyid;
1797         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1798         push @debsign_cmd, $changesfile;
1799         runcmd_ordryrun @debsign_cmd;
1800     }
1801 }
1802
1803 sub dopush ($) {
1804     my ($forceflag) = @_;
1805     printdebug "actually entering push\n";
1806     prep_ud();
1807
1808     access_giturl(); # check that success is vaguely likely
1809
1810     my $clogpfn = ".git/dgit/changelog.822.tmp";
1811     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1812
1813     responder_send_file('parsed-changelog', $clogpfn);
1814
1815     my ($clogp, $cversion, $tag, $dscfn) =
1816         push_parse_changelog("$clogpfn");
1817
1818     my $dscpath = "$buildproductsdir/$dscfn";
1819     stat_exists $dscpath or
1820         fail "looked for .dsc $dscfn, but $!;".
1821             " maybe you forgot to build";
1822
1823     responder_send_file('dsc', $dscpath);
1824
1825     push_parse_dsc($dscpath, $dscfn, $cversion);
1826
1827     my $format = getfield $dsc, 'Format';
1828     printdebug "format $format\n";
1829     if (madformat($format)) {
1830         commit_quilty_patch();
1831     }
1832     check_not_dirty();
1833     changedir $ud;
1834     progress "checking that $dscfn corresponds to HEAD";
1835     runcmd qw(dpkg-source -x --),
1836         $dscpath =~ m#^/# ? $dscpath : "../../../$dscpath";
1837     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1838     check_for_vendor_patches() if madformat($dsc->{format});
1839     changedir '../../../..';
1840     my $diffopt = $debuglevel>0 ? '--exit-code' : '--quiet';
1841     my @diffcmd = (@git, qw(diff), $diffopt, $tree);
1842     debugcmd "+",@diffcmd;
1843     $!=0; $?=0;
1844     my $r = system @diffcmd;
1845     if ($r) {
1846         if ($r==256) {
1847             fail "$dscfn specifies a different tree to your HEAD commit;".
1848                 " perhaps you forgot to build".
1849                 ($diffopt eq '--exit-code' ? "" :
1850                  " (run with -D to see full diff output)");
1851         } else {
1852             failedcmd @diffcmd;
1853         }
1854     }
1855     my $head = git_rev_parse('HEAD');
1856     if (!$changesfile) {
1857         my $multi = "$buildproductsdir/".
1858             "${package}_".(stripepoch $cversion)."_multi.changes";
1859         if (stat_exists "$multi") {
1860             $changesfile = $multi;
1861         } else {
1862             my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1863             my @cs = glob "$buildproductsdir/$pat";
1864             fail "failed to find unique changes file".
1865                 " (looked for $pat in $buildproductsdir, or $multi);".
1866                 " perhaps you need to use dgit -C"
1867                 unless @cs==1;
1868             ($changesfile) = @cs;
1869         }
1870     } else {
1871         $changesfile = "$buildproductsdir/$changesfile";
1872     }
1873
1874     responder_send_file('changes',$changesfile);
1875     responder_send_command("param head $head");
1876     responder_send_command("param csuite $csuite");
1877
1878     if (deliberately_not_fast_forward) {
1879         git_for_each_ref(lrfetchrefs, sub {
1880             my ($objid,$objtype,$lrfetchrefname,$reftail) = @_;
1881             my $rrefname= substr($lrfetchrefname, length(lrfetchrefs) + 1);
1882             responder_send_command("previously $rrefname=$objid");
1883             $previously{$rrefname} = $objid;
1884         });
1885     }
1886
1887     my $tfn = sub { ".git/dgit/tag$_[0]"; };
1888     my $tagobjfn;
1889
1890     if ($we_are_responder) {
1891         $tagobjfn = $tfn->('.signed.tmp');
1892         responder_receive_files('signed-tag', $tagobjfn);
1893     } else {
1894         $tagobjfn =
1895             push_mktag($head,$clogp,$tag,
1896                        $dscpath,
1897                        $changesfile,$changesfile,
1898                        $tfn);
1899     }
1900
1901     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1902     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1903     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1904
1905     if (!check_for_git()) {
1906         create_remote_git_repo();
1907     }
1908     runcmd_ordryrun @git, qw(push),access_giturl(),
1909         $forceflag."HEAD:".rrref(), $forceflag."refs/tags/$tag";
1910     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1911
1912     if ($we_are_responder) {
1913         my $dryrunsuffix = act_local() ? "" : ".tmp";
1914         responder_receive_files('signed-dsc-changes',
1915                                 "$dscpath$dryrunsuffix",
1916                                 "$changesfile$dryrunsuffix");
1917     } else {
1918         if (act_local()) {
1919             rename "$dscpath.tmp",$dscpath or die "$dscfn $!";
1920         } else {
1921             progress "[new .dsc left in $dscpath.tmp]";
1922         }
1923         sign_changes $changesfile;
1924     }
1925
1926     my $host = access_cfg('upload-host','RETURN-UNDEF');
1927     my @hostarg = defined($host) ? ($host,) : ();
1928     runcmd_ordryrun @dput, @hostarg, $changesfile;
1929     printdone "pushed and uploaded $cversion";
1930
1931     responder_send_command("complete");
1932 }
1933
1934 sub cmd_clone {
1935     parseopts();
1936     my $dstdir;
1937     badusage "-p is not allowed with clone; specify as argument instead"
1938         if defined $package;
1939     if (@ARGV==1) {
1940         ($package) = @ARGV;
1941     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1942         ($package,$isuite) = @ARGV;
1943     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1944         ($package,$dstdir) = @ARGV;
1945     } elsif (@ARGV==3) {
1946         ($package,$isuite,$dstdir) = @ARGV;
1947     } else {
1948         badusage "incorrect arguments to dgit clone";
1949     }
1950     $dstdir ||= "$package";
1951
1952     if (stat_exists $dstdir) {
1953         fail "$dstdir already exists";
1954     }
1955
1956     my $cwd_remove;
1957     if ($rmonerror && !$dryrun_level) {
1958         $cwd_remove= getcwd();
1959         unshift @end, sub {
1960             return unless defined $cwd_remove;
1961             if (!chdir "$cwd_remove") {
1962                 return if $!==&ENOENT;
1963                 die "chdir $cwd_remove: $!";
1964             }
1965             rmtree($dstdir) or die "remove $dstdir: $!\n";
1966         };
1967     }
1968
1969     clone($dstdir);
1970     $cwd_remove = undef;
1971 }
1972
1973 sub branchsuite () {
1974     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1975     if ($branch =~ m#$lbranch_re#o) {
1976         return $1;
1977     } else {
1978         return undef;
1979     }
1980 }
1981
1982 sub fetchpullargs () {
1983     if (!defined $package) {
1984         my $sourcep = parsecontrol('debian/control','debian/control');
1985         $package = getfield $sourcep, 'Source';
1986     }
1987     if (@ARGV==0) {
1988 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
1989         if (!$isuite) {
1990             my $clogp = parsechangelog();
1991             $isuite = getfield $clogp, 'Distribution';
1992         }
1993         canonicalise_suite();
1994         progress "fetching from suite $csuite";
1995     } elsif (@ARGV==1) {
1996         ($isuite) = @ARGV;
1997         canonicalise_suite();
1998     } else {
1999         badusage "incorrect arguments to dgit fetch or dgit pull";
2000     }
2001 }
2002
2003 sub cmd_fetch {
2004     parseopts();
2005     fetchpullargs();
2006     fetch();
2007 }
2008
2009 sub cmd_pull {
2010     parseopts();
2011     fetchpullargs();
2012     pull();
2013 }
2014
2015 sub cmd_push {
2016     pushing();
2017     parseopts();
2018     badusage "-p is not allowed with dgit push" if defined $package;
2019     check_not_dirty();
2020     my $clogp = parsechangelog();
2021     $package = getfield $clogp, 'Source';
2022     my $specsuite;
2023     if (@ARGV==0) {
2024     } elsif (@ARGV==1) {
2025         ($specsuite) = (@ARGV);
2026     } else {
2027         badusage "incorrect arguments to dgit push";
2028     }
2029     $isuite = getfield $clogp, 'Distribution';
2030     if ($new_package) {
2031         local ($package) = $existing_package; # this is a hack
2032         canonicalise_suite();
2033     } else {
2034         canonicalise_suite();
2035     }
2036     if (defined $specsuite &&
2037         $specsuite ne $isuite &&
2038         $specsuite ne $csuite) {
2039             fail "dgit push: changelog specifies $isuite ($csuite)".
2040                 " but command line specifies $specsuite";
2041     }
2042     if (check_for_git()) {
2043         git_fetch_us();
2044     }
2045     my $forceflag = '';
2046     if (fetch_from_archive()) {
2047         if (is_fast_fwd(lrref(), 'HEAD')) {
2048             # ok
2049         } elsif (deliberately_not_fast_forward) {
2050             $forceflag = '+';
2051         } else {
2052             fail "dgit push: HEAD is not a descendant".
2053                 " of the archive's version.\n".
2054                 "dgit: To overwrite its contents,".
2055                 " use git merge -s ours ".lrref().".\n".
2056                 "dgit: To rewind history, if permitted by the archive,".
2057                 " use --deliberately-not-fast-forward";
2058         }
2059     } else {
2060         $new_package or
2061             fail "package appears to be new in this suite;".
2062                 " if this is intentional, use --new";
2063     }
2064     dopush($forceflag);
2065 }
2066
2067 #---------- remote commands' implementation ----------
2068
2069 sub cmd_remote_push_build_host {
2070     pushing();
2071     my ($nrargs) = shift @ARGV;
2072     my (@rargs) = @ARGV[0..$nrargs-1];
2073     @ARGV = @ARGV[$nrargs..$#ARGV];
2074     die unless @rargs;
2075     my ($dir,$vsnwant) = @rargs;
2076     # vsnwant is a comma-separated list; we report which we have
2077     # chosen in our ready response (so other end can tell if they
2078     # offered several)
2079     $debugprefix = ' ';
2080     $we_are_responder = 1;
2081     $us .= " (build host)";
2082
2083     open PI, "<&STDIN" or die $!;
2084     open STDIN, "/dev/null" or die $!;
2085     open PO, ">&STDOUT" or die $!;
2086     autoflush PO 1;
2087     open STDOUT, ">&STDERR" or die $!;
2088     autoflush STDOUT 1;
2089
2090     $vsnwant //= 1;
2091     fail "build host has dgit rpush protocol version".
2092         " $rpushprotovsn but invocation host has $vsnwant"
2093         unless grep { $rpushprotovsn eq $_ } split /,/, $vsnwant;
2094
2095     responder_send_command("dgit-remote-push-ready $rpushprotovsn");
2096
2097     changedir $dir;
2098     &cmd_push;
2099 }
2100
2101 sub cmd_remote_push_responder { cmd_remote_push_build_host(); }
2102 # ... for compatibility with proto vsn.1 dgit (just so that user gets
2103 #     a good error message)
2104
2105 our $i_tmp;
2106
2107 sub i_cleanup {
2108     local ($@, $?);
2109     my $report = i_child_report();
2110     if (defined $report) {
2111         printdebug "($report)\n";
2112     } elsif ($i_child_pid) {
2113         printdebug "(killing build host child $i_child_pid)\n";
2114         kill 15, $i_child_pid;
2115     }
2116     if (defined $i_tmp && !defined $initiator_tempdir) {
2117         changedir "/";
2118         eval { rmtree $i_tmp; };
2119     }
2120 }
2121
2122 END { i_cleanup(); }
2123
2124 sub i_method {
2125     my ($base,$selector,@args) = @_;
2126     $selector =~ s/\-/_/g;
2127     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
2128 }
2129
2130 sub cmd_rpush {
2131     pushing();
2132     my $host = nextarg;
2133     my $dir;
2134     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
2135         $host = $1;
2136         $dir = $'; #';
2137     } else {
2138         $dir = nextarg;
2139     }
2140     $dir =~ s{^-}{./-};
2141     my @rargs = ($dir,$rpushprotovsn);
2142     my @rdgit;
2143     push @rdgit, @dgit;
2144     push @rdgit, @ropts;
2145     push @rdgit, qw(remote-push-build-host), (scalar @rargs), @rargs;
2146     push @rdgit, @ARGV;
2147     my @cmd = (@ssh, $host, shellquote @rdgit);
2148     debugcmd "+",@cmd;
2149
2150     if (defined $initiator_tempdir) {
2151         rmtree $initiator_tempdir;
2152         mkdir $initiator_tempdir, 0700 or die "$initiator_tempdir: $!";
2153         $i_tmp = $initiator_tempdir;
2154     } else {
2155         $i_tmp = tempdir();
2156     }
2157     $i_child_pid = open2(\*RO, \*RI, @cmd);
2158     changedir $i_tmp;
2159     initiator_expect { m/^dgit-remote-push-ready/ };
2160     for (;;) {
2161         my ($icmd,$iargs) = initiator_expect {
2162             m/^(\S+)(?: (.*))?$/;
2163             ($1,$2);
2164         };
2165         i_method "i_resp", $icmd, $iargs;
2166     }
2167 }
2168
2169 sub i_resp_progress ($) {
2170     my ($rhs) = @_;
2171     my $msg = protocol_read_bytes \*RO, $rhs;
2172     progress $msg;
2173 }
2174
2175 sub i_resp_complete {
2176     my $pid = $i_child_pid;
2177     $i_child_pid = undef; # prevents killing some other process with same pid
2178     printdebug "waiting for build host child $pid...\n";
2179     my $got = waitpid $pid, 0;
2180     die $! unless $got == $pid;
2181     die "build host child failed $?" if $?;
2182
2183     i_cleanup();
2184     printdebug "all done\n";
2185     exit 0;
2186 }
2187
2188 sub i_resp_file ($) {
2189     my ($keyword) = @_;
2190     my $localname = i_method "i_localname", $keyword;
2191     my $localpath = "$i_tmp/$localname";
2192     stat_exists $localpath and
2193         badproto \*RO, "file $keyword ($localpath) twice";
2194     protocol_receive_file \*RO, $localpath;
2195     i_method "i_file", $keyword;
2196 }
2197
2198 our %i_param;
2199
2200 sub i_resp_param ($) {
2201     $_[0] =~ m/^(\S+) (.*)$/ or badproto \*RO, "bad param spec";
2202     $i_param{$1} = $2;
2203 }
2204
2205 sub i_resp_previously ($) {
2206     $_[0] =~ m#^(refs/tags/\S+)=(\w+)$#
2207         or badproto \*RO, "bad previously spec";
2208     my $r = system qw(git check-ref-format), $1;
2209     die "bad previously ref spec ($r)" if $r;
2210     $previously{$1} = $2;
2211 }
2212
2213 our %i_wanted;
2214
2215 sub i_resp_want ($) {
2216     my ($keyword) = @_;
2217     die "$keyword ?" if $i_wanted{$keyword}++;
2218     my @localpaths = i_method "i_want", $keyword;
2219     printdebug "[[  $keyword @localpaths\n";
2220     foreach my $localpath (@localpaths) {
2221         protocol_send_file \*RI, $localpath;
2222     }
2223     print RI "files-end\n" or die $!;
2224 }
2225
2226 our ($i_clogp, $i_version, $i_tag, $i_dscfn, $i_changesfn);
2227
2228 sub i_localname_parsed_changelog {
2229     return "remote-changelog.822";
2230 }
2231 sub i_file_parsed_changelog {
2232     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
2233         push_parse_changelog "$i_tmp/remote-changelog.822";
2234     die if $i_dscfn =~ m#/|^\W#;
2235 }
2236
2237 sub i_localname_dsc {
2238     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2239     return $i_dscfn;
2240 }
2241 sub i_file_dsc { }
2242
2243 sub i_localname_changes {
2244     defined $i_dscfn or badproto \*RO, "dsc (before parsed-changelog)";
2245     $i_changesfn = $i_dscfn;
2246     $i_changesfn =~ s/\.dsc$/_dgit.changes/ or die;
2247     return $i_changesfn;
2248 }
2249 sub i_file_changes { }
2250
2251 sub i_want_signed_tag {
2252     printdebug Dumper(\%i_param, $i_dscfn);
2253     defined $i_param{'head'} && defined $i_dscfn && defined $i_clogp
2254         && defined $i_param{'csuite'}
2255         or badproto \*RO, "premature desire for signed-tag";
2256     my $head = $i_param{'head'};
2257     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
2258
2259     die unless $i_param{'csuite'} =~ m/^$suite_re$/;
2260     $csuite = $&;
2261     push_parse_dsc $i_dscfn, 'remote dsc', $i_version;
2262
2263     my $tagobjfn =
2264         push_mktag $head, $i_clogp, $i_tag,
2265             $i_dscfn,
2266             $i_changesfn, 'remote changes',
2267             sub { "tag$_[0]"; };
2268
2269     return $tagobjfn;
2270 }
2271
2272 sub i_want_signed_dsc_changes {
2273     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
2274     sign_changes $i_changesfn;
2275     return ($i_dscfn, $i_changesfn);
2276 }
2277
2278 #---------- building etc. ----------
2279
2280 our $version;
2281 our $sourcechanges;
2282 our $dscfn;
2283
2284 #----- `3.0 (quilt)' handling -----
2285
2286 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
2287
2288 sub quiltify_dpkg_commit ($$$;$) {
2289     my ($patchname,$author,$msg, $xinfo) = @_;
2290     $xinfo //= '';
2291
2292     mkpath '.git/dgit';
2293     my $descfn = ".git/dgit/quilt-description.tmp";
2294     open O, '>', $descfn or die "$descfn: $!";
2295     $msg =~ s/\s+$//g;
2296     $msg =~ s/\n/\n /g;
2297     $msg =~ s/^\s+$/ ./mg;
2298     print O <<END or die $!;
2299 Description: $msg
2300 Author: $author
2301 $xinfo
2302 ---
2303
2304 END
2305     close O or die $!;
2306
2307     {
2308         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
2309         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
2310         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
2311         runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
2312     }
2313 }
2314
2315 sub quiltify_trees_differ ($$) {
2316     my ($x,$y) = @_;
2317     # returns 1 iff the two tree objects differ other than in debian/
2318     local $/=undef;
2319     my @cmd = (@git, qw(diff-tree --name-only -z), $x, $y);
2320     my $diffs= cmdoutput @cmd;
2321     foreach my $f (split /\0/, $diffs) {
2322         next if $f eq 'debian';
2323         return 1;
2324     }
2325     return 0;
2326 }
2327
2328 sub quiltify_tree_sentinelfiles ($) {
2329     # lists the `sentinel' files present in the tree
2330     my ($x) = @_;
2331     my $r = cmdoutput @git, qw(ls-tree --name-only), $x,
2332         qw(-- debian/rules debian/control);
2333     $r =~ s/\n/,/g;
2334     return $r;
2335 }
2336
2337 sub quiltify ($$) {
2338     my ($clogp,$target) = @_;
2339
2340     # Quilt patchification algorithm
2341     #
2342     # We search backwards through the history of the main tree's HEAD
2343     # (T) looking for a start commit S whose tree object is identical
2344     # to to the patch tip tree (ie the tree corresponding to the
2345     # current dpkg-committed patch series).  For these purposes
2346     # `identical' disregards anything in debian/ - this wrinkle is
2347     # necessary because dpkg-source treates debian/ specially.
2348     #
2349     # We can only traverse edges where at most one of the ancestors'
2350     # trees differs (in changes outside in debian/).  And we cannot
2351     # handle edges which change .pc/ or debian/patches.  To avoid
2352     # going down a rathole we avoid traversing edges which introduce
2353     # debian/rules or debian/control.  And we set a limit on the
2354     # number of edges we are willing to look at.
2355     #
2356     # If we succeed, we walk forwards again.  For each traversed edge
2357     # PC (with P parent, C child) (starting with P=S and ending with
2358     # C=T) to we do this:
2359     #  - git checkout C
2360     #  - dpkg-source --commit with a patch name and message derived from C
2361     # After traversing PT, we git commit the changes which
2362     # should be contained within debian/patches.
2363
2364     changedir '../fake';
2365     remove_stray_gits();
2366     mktree_in_ud_here();
2367     rmtree '.pc';
2368     runcmd @git, 'add', '.';
2369     my $oldtiptree=git_write_tree();
2370     changedir '../work';
2371
2372     # The search for the path S..T is breadth-first.  We maintain a
2373     # todo list containing search nodes.  A search node identifies a
2374     # commit, and looks something like this:
2375     #  $p = {
2376     #      Commit => $git_commit_id,
2377     #      Child => $c,                          # or undef if P=T
2378     #      Whynot => $reason_edge_PC_unsuitable, # in @nots only
2379     #      Nontrivial => true iff $p..$c has relevant changes
2380     #  };
2381
2382     my @todo;
2383     my @nots;
2384     my $sref_S;
2385     my $max_work=100;
2386     my %considered; # saves being exponential on some weird graphs
2387
2388     my $t_sentinels = quiltify_tree_sentinelfiles $target;
2389
2390     my $not = sub {
2391         my ($search,$whynot) = @_;
2392         printdebug " search NOT $search->{Commit} $whynot\n";
2393         $search->{Whynot} = $whynot;
2394         push @nots, $search;
2395         no warnings qw(exiting);
2396         next;
2397     };
2398
2399     push @todo, {
2400         Commit => $target,
2401     };
2402
2403     while (@todo) {
2404         my $c = shift @todo;
2405         next if $considered{$c->{Commit}}++;
2406
2407         $not->($c, "maximum search space exceeded") if --$max_work <= 0;
2408
2409         printdebug "quiltify investigate $c->{Commit}\n";
2410
2411         # are we done?
2412         if (!quiltify_trees_differ $c->{Commit}, $oldtiptree) {
2413             printdebug " search finished hooray!\n";
2414             $sref_S = $c;
2415             last;
2416         }
2417
2418         if ($quilt_mode eq 'nofix') {
2419             fail "quilt fixup required but quilt mode is \`nofix'\n".
2420                 "HEAD commit $c->{Commit} differs from tree implied by ".
2421                 " debian/patches (tree object $oldtiptree)";
2422         }
2423         if ($quilt_mode eq 'smash') {
2424             printdebug " search quitting smash\n";
2425             last;
2426         }
2427
2428         my $c_sentinels = quiltify_tree_sentinelfiles $c->{Commit};
2429         $not->($c, "has $c_sentinels not $t_sentinels")
2430             if $c_sentinels ne $t_sentinels;
2431
2432         my $commitdata = cmdoutput @git, qw(cat-file commit), $c->{Commit};
2433         $commitdata =~ m/\n\n/;
2434         $commitdata =~ $`;
2435         my @parents = ($commitdata =~ m/^parent (\w+)$/gm);
2436         @parents = map { { Commit => $_, Child => $c } } @parents;
2437
2438         $not->($c, "root commit") if !@parents;
2439
2440         foreach my $p (@parents) {
2441             $p->{Nontrivial}= quiltify_trees_differ $p->{Commit},$c->{Commit};
2442         }
2443         my $ndiffers = grep { $_->{Nontrivial} } @parents;
2444         $not->($c, "merge ($ndiffers nontrivial parents)") if $ndiffers > 1;
2445
2446         foreach my $p (@parents) {
2447             printdebug "considering C=$c->{Commit} P=$p->{Commit}\n";
2448
2449             my @cmd= (@git, qw(diff-tree -r --name-only),
2450                       $p->{Commit},$c->{Commit}, qw(-- debian/patches .pc));
2451             my $patchstackchange = cmdoutput @cmd;
2452             if (length $patchstackchange) {
2453                 $patchstackchange =~ s/\n/,/g;
2454                 $not->($p, "changed $patchstackchange");
2455             }
2456
2457             printdebug " search queue P=$p->{Commit} ",
2458                 ($p->{Nontrivial} ? "NT" : "triv"),"\n";
2459             push @todo, $p;
2460         }
2461     }
2462
2463     if (!$sref_S) {
2464         printdebug "quiltify want to smash\n";
2465
2466         my $abbrev = sub {
2467             my $x = $_[0]{Commit};
2468             $x =~ s/(.*?[0-9a-z]{8})[0-9a-z]*$/$1/;
2469             return $;
2470         };
2471         my $reportnot = sub {
2472             my ($notp) = @_;
2473             my $s = $abbrev->($notp);
2474             my $c = $notp->{Child};
2475             $s .= "..".$abbrev->($c) if $c;
2476             $s .= ": ".$notp->{Whynot};
2477             return $s;
2478         };
2479         if ($quilt_mode eq 'linear') {
2480             print STDERR "$us: quilt fixup cannot be linear.  Stopped at:\n";
2481             foreach my $notp (@nots) {
2482                 print STDERR "$us:  ", $reportnot->($notp), "\n";
2483             }
2484             fail "quilt fixup naive history linearisation failed.\n".
2485  "Use dpkg-source --commit by hand; or, --quilt=smash for one ugly patch";
2486         } elsif ($quilt_mode eq 'smash') {
2487         } elsif ($quilt_mode eq 'auto') {
2488             progress "quilt fixup cannot be linear, smashing...";
2489         } else {
2490             die "$quilt_mode ?";
2491         }
2492
2493         my $time = time;
2494         my $ncommits = 3;
2495         my $msg = cmdoutput @git, qw(log), "-n$ncommits";
2496
2497         quiltify_dpkg_commit "auto-$version-$target-$time",
2498             (getfield $clogp, 'Maintainer'),
2499             "Automatically generated patch ($clogp->{Version})\n".
2500             "Last (up to) $ncommits git changes, FYI:\n\n". $msg;
2501         return;
2502     }
2503
2504     progress "quiltify linearisation planning successful, executing...";
2505
2506     for (my $p = $sref_S;
2507          my $c = $p->{Child};
2508          $p = $p->{Child}) {
2509         printdebug "quiltify traverse $p->{Commit}..$c->{Commit}\n";
2510         next unless $p->{Nontrivial};
2511
2512         my $cc = $c->{Commit};
2513
2514         my $commitdata = cmdoutput @git, qw(cat-file commit), $cc;
2515         $commitdata =~ m/\n\n/ or die "$c ?";
2516         $commitdata = $`;
2517         my $msg = $'; #';
2518         $commitdata =~ m/^author (.*) \d+ [-+0-9]+$/m or die "$cc ?";
2519         my $author = $1;
2520
2521         $msg =~ s/^(.*)\n*/$1\n/ or die "$cc $msg ?";
2522
2523         my $title = $1;
2524         my $patchname = $title;
2525         $patchname =~ s/[.:]$//;
2526         $patchname =~ y/ A-Z/-a-z/;
2527         $patchname =~ y/-a-z0-9_.+=~//cd;
2528         $patchname =~ s/^\W/x-$&/;
2529         $patchname = substr($patchname,0,40);
2530         my $index;
2531         for ($index='';
2532              stat "debian/patches/$patchname$index";
2533              $index++) { }
2534         $!==ENOENT or die "$patchname$index $!";
2535
2536         runcmd @git, qw(checkout -q), $cc;
2537
2538         # We use the tip's changelog so that dpkg-source doesn't
2539         # produce complaining messages from dpkg-parsechangelog.  None
2540         # of the information dpkg-source gets from the changelog is
2541         # actually relevant - it gets put into the original message
2542         # which dpkg-source provides our stunt editor, and then
2543         # overwritten.
2544         runcmd @git, qw(checkout -q), $target, qw(debian/changelog);
2545
2546         quiltify_dpkg_commit "$patchname$index", $author, $msg,
2547             "X-Dgit-Generated: $clogp->{Version} $cc\n";
2548
2549         runcmd @git, qw(checkout -q), $cc, qw(debian/changelog);
2550     }
2551
2552     runcmd @git, qw(checkout -q master);
2553 }
2554
2555 sub build_maybe_quilt_fixup () {
2556     my $format=get_source_format;
2557     return unless madformat $format;
2558     # sigh
2559
2560     check_for_vendor_patches();
2561
2562     # Our objective is:
2563     #  - honour any existing .pc in case it has any strangeness
2564     #  - determine the git commit corresponding to the tip of
2565     #    the patch stack (if there is one)
2566     #  - if there is such a git commit, convert each subsequent
2567     #    git commit into a quilt patch with dpkg-source --commit
2568     #  - otherwise convert all the differences in the tree into
2569     #    a single git commit
2570     #
2571     # To do this we:
2572
2573     # Our git tree doesn't necessarily contain .pc.  (Some versions of
2574     # dgit would include the .pc in the git tree.)  If there isn't
2575     # one, we need to generate one by unpacking the patches that we
2576     # have.
2577     #
2578     # We first look for a .pc in the git tree.  If there is one, we
2579     # will use it.  (This is not the normal case.)
2580     #
2581     # Otherwise need to regenerate .pc so that dpkg-source --commit
2582     # can work.  We do this as follows:
2583     #     1. Collect all relevant .orig from parent directory
2584     #     2. Generate a debian.tar.gz out of
2585     #         debian/{patches,rules,source/format}
2586     #     3. Generate a fake .dsc containing just these fields:
2587     #          Format Source Version Files
2588     #     4. Extract the fake .dsc
2589     #        Now the fake .dsc has a .pc directory.
2590     # (In fact we do this in every case, because in future we will
2591     # want to search for a good base commit for generating patches.)
2592     #
2593     # Then we can actually do the dpkg-source --commit
2594     #     1. Make a new working tree with the same object
2595     #        store as our main tree and check out the main
2596     #        tree's HEAD.
2597     #     2. Copy .pc from the fake's extraction, if necessary
2598     #     3. Run dpkg-source --commit
2599     #     4. If the result has changes to debian/, then
2600     #          - git-add them them
2601     #          - git-add .pc if we had a .pc in-tree
2602     #          - git-commit
2603     #     5. If we had a .pc in-tree, delete it, and git-commit
2604     #     6. Back in the main tree, fast forward to the new HEAD
2605
2606     my $clogp = parsechangelog();
2607     my $headref = git_rev_parse('HEAD');
2608
2609     prep_ud();
2610     changedir $ud;
2611
2612     my $upstreamversion=$version;
2613     $upstreamversion =~ s/-[^-]*$//;
2614
2615     my $fakeversion="$upstreamversion-~~DGITFAKE";
2616
2617     my $fakedsc=new IO::File 'fake.dsc', '>' or die $!;
2618     print $fakedsc <<END or die $!;
2619 Format: 3.0 (quilt)
2620 Source: $package
2621 Version: $fakeversion
2622 Files:
2623 END
2624
2625     my $dscaddfile=sub {
2626         my ($b) = @_;
2627
2628         my $md = new Digest::MD5;
2629
2630         my $fh = new IO::File $b, '<' or die "$b $!";
2631         stat $fh or die $!;
2632         my $size = -s _;
2633
2634         $md->addfile($fh);
2635         print $fakedsc " ".$md->hexdigest." $size $b\n" or die $!;
2636     };
2637
2638     foreach my $f (<../../../../*>) { #/){
2639         my $b=$f; $b =~ s{.*/}{};
2640         next unless is_orig_file $b, srcfn $upstreamversion,'';
2641         link $f, $b or die "$b $!";
2642         $dscaddfile->($b);
2643     }
2644
2645     my @files=qw(debian/source/format debian/rules);
2646     if (stat_exists '../../../debian/patches') {
2647         push @files, 'debian/patches';
2648     }
2649
2650     my $debtar= srcfn $fakeversion,'.debian.tar.gz';
2651     runcmd qw(env GZIP=-1 tar -zcf), "./$debtar", qw(-C ../../..), @files;
2652
2653     $dscaddfile->($debtar);
2654     close $fakedsc or die $!;
2655
2656     runcmd qw(sh -ec), 'exec dpkg-source --no-check -x fake.dsc >/dev/null';
2657
2658     my $fakexdir= $package.'-'.(stripepoch $upstreamversion);
2659     rename $fakexdir, "fake" or die "$fakexdir $!";
2660
2661     mkdir "work" or die $!;
2662     changedir "work";
2663     mktree_in_ud_here();
2664     runcmd @git, qw(reset --hard), $headref;
2665
2666     my $mustdeletepc=0;
2667     if (stat_exists ".pc") {
2668         -d _ or die;
2669         progress "Tree already contains .pc - will use it then delete it.";
2670         $mustdeletepc=1;
2671     } else {
2672         rename '../fake/.pc','.pc' or die $!;
2673     }
2674
2675     quiltify($clogp,$headref);
2676
2677     if (!open P, '>>', ".pc/applied-patches") {
2678         $!==&ENOENT or die $!;
2679     } else {
2680         close P;
2681     }
2682
2683     commit_quilty_patch();
2684
2685     if ($mustdeletepc) {
2686         runcmd @git, qw(rm -rqf .pc);
2687         commit_admin "Commit removal of .pc (quilt series tracking data)";
2688     }
2689
2690     changedir '../../../..';
2691     runcmd @git, qw(pull --ff-only -q .git/dgit/unpack/work master);
2692 }
2693
2694 sub quilt_fixup_editor () {
2695     my $descfn = $ENV{$fakeeditorenv};
2696     my $editing = $ARGV[$#ARGV];
2697     open I1, '<', $descfn or die "$descfn: $!";
2698     open I2, '<', $editing or die "$editing: $!";
2699     unlink $editing or die "$editing: $!";
2700     open O, '>', $editing or die "$editing: $!";
2701     while (<I1>) { print O or die $!; } I1->error and die $!;
2702     my $copying = 0;
2703     while (<I2>) {
2704         $copying ||= m/^\-\-\- /;
2705         next unless $copying;
2706         print O or die $!;
2707     }
2708     I2->error and die $!;
2709     close O or die $1;
2710     exit 0;
2711 }
2712
2713 #----- other building -----
2714
2715 sub clean_tree () {
2716     if ($cleanmode eq 'dpkg-source') {
2717         runcmd_ordryrun_local @dpkgbuildpackage, qw(-T clean);
2718     } elsif ($cleanmode eq 'dpkg-source-d') {
2719         runcmd_ordryrun_local @dpkgbuildpackage, qw(-d -T clean);
2720     } elsif ($cleanmode eq 'git') {
2721         runcmd_ordryrun_local @git, qw(clean -xdf);
2722     } elsif ($cleanmode eq 'git-ff') {
2723         runcmd_ordryrun_local @git, qw(clean -xdff);
2724     } elsif ($cleanmode eq 'check') {
2725         my $leftovers = cmdoutput @git, qw(clean -xdn);
2726         if (length $leftovers) {
2727             print STDERR $leftovers, "\n" or die $!;
2728             fail "tree contains uncommitted files and --clean=check specified";
2729         }
2730     } elsif ($cleanmode eq 'none') {
2731     } else {
2732         die "$cleanmode ?";
2733     }
2734 }
2735
2736 sub cmd_clean () {
2737     badusage "clean takes no additional arguments" if @ARGV;
2738     clean_tree();
2739 }
2740
2741 sub build_prep () {
2742     badusage "-p is not allowed when building" if defined $package;
2743     check_not_dirty();
2744     clean_tree();
2745     my $clogp = parsechangelog();
2746     $isuite = getfield $clogp, 'Distribution';
2747     $package = getfield $clogp, 'Source';
2748     $version = getfield $clogp, 'Version';
2749     build_maybe_quilt_fixup();
2750 }
2751
2752 sub changesopts () {
2753     my @opts =@changesopts[1..$#changesopts];
2754     if (!defined $changes_since_version) {
2755         my @vsns = archive_query('archive_query');
2756         my @quirk = access_quirk();
2757         if ($quirk[0] eq 'backports') {
2758             local $isuite = $quirk[2];
2759             local $csuite;
2760             canonicalise_suite();
2761             push @vsns, archive_query('archive_query');
2762         }
2763         if (@vsns) {
2764             @vsns = map { $_->[0] } @vsns;
2765             @vsns = sort { -version_compare($a, $b) } @vsns;
2766             $changes_since_version = $vsns[0];
2767             progress "changelog will contain changes since $vsns[0]";
2768         } else {
2769             $changes_since_version = '_';
2770             progress "package seems new, not specifying -v<version>";
2771         }
2772     }
2773     if ($changes_since_version ne '_') {
2774         unshift @opts, "-v$changes_since_version";
2775     }
2776     return @opts;
2777 }
2778
2779 sub massage_dbp_args ($) {
2780     my ($cmd) = @_;
2781     return unless $cleanmode =~ m/git|none/;
2782     debugcmd '#massaging#', @$cmd if $debuglevel>1;
2783     my @newcmd = shift @$cmd;
2784     # -nc has the side effect of specifying -b if nothing else specified
2785     push @newcmd, '-nc';
2786     # and some combinations of -S, -b, et al, are errors, rather than
2787     # later simply overriding earlier
2788     push @newcmd, '-F' unless grep { m/^-[bBASF]$/ } @$cmd;
2789     push @newcmd, @$cmd;
2790     @$cmd = @newcmd;
2791 }
2792
2793 sub cmd_build {
2794     build_prep();
2795     my @dbp = (@dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV);
2796     massage_dbp_args \@dbp;
2797     runcmd_ordryrun_local @dbp;
2798     printdone "build successful\n";
2799 }
2800
2801 sub cmd_git_build {
2802     build_prep();
2803     my @dbp = @dpkgbuildpackage;
2804     massage_dbp_args \@dbp;
2805     my @cmd =
2806         (qw(git-buildpackage -us -uc --git-no-sign-tags),
2807          "--git-builder=@dbp");
2808     unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
2809         canonicalise_suite();
2810         push @cmd, "--git-debian-branch=".lbranch();
2811     }
2812     push @cmd, changesopts();
2813     runcmd_ordryrun_local @cmd, @ARGV;
2814     printdone "build successful\n";
2815 }
2816
2817 sub build_source {
2818     build_prep();
2819     $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
2820     $dscfn = dscfn($version);
2821     if ($cleanmode eq 'dpkg-source') {
2822         runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
2823             changesopts();
2824     } elsif ($cleanmode eq 'dpkg-source-d') {
2825         runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S -d)),
2826             changesopts();
2827     } else {
2828         my $pwd = must_getcwd();
2829         my $leafdir = basename $pwd;
2830         changedir "..";
2831         runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
2832         changedir $pwd;
2833         runcmd_ordryrun_local qw(sh -ec),
2834             'exec >$1; shift; exec "$@"','x',
2835             "../$sourcechanges",
2836             @dpkggenchanges, qw(-S), changesopts();
2837     }
2838 }
2839
2840 sub cmd_build_source {
2841     badusage "build-source takes no additional arguments" if @ARGV;
2842     build_source();
2843     printdone "source built, results in $dscfn and $sourcechanges";
2844 }
2845
2846 sub cmd_sbuild {
2847     build_source();
2848     changedir "..";
2849     my $pat = "${package}_".(stripepoch $version)."_*.changes";
2850     if (act_local()) {
2851         stat_exists $dscfn or fail "$dscfn (in parent directory): $!";
2852         stat_exists $sourcechanges
2853             or fail "$sourcechanges (in parent directory): $!";
2854         foreach my $cf (glob $pat) {
2855             next if $cf eq $sourcechanges;
2856             unlink $cf or fail "remove $cf: $!";
2857         }
2858     }
2859     runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
2860     my @changesfiles = glob $pat;
2861     @changesfiles = sort {
2862         ($b =~ m/_source\.changes$/ <=> $a =~ m/_source\.changes$/)
2863             or $a cmp $b
2864     } @changesfiles;
2865     fail "wrong number of different changes files (@changesfiles)"
2866         unless @changesfiles;
2867     runcmd_ordryrun_local @mergechanges, @changesfiles;
2868     my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
2869     if (act_local()) {
2870         stat_exists $multichanges or fail "$multichanges: $!";
2871     }
2872     printdone "build successful, results in $multichanges\n" or die $!;
2873 }
2874
2875 sub cmd_quilt_fixup {
2876     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
2877     my $clogp = parsechangelog();
2878     $version = getfield $clogp, 'Version';
2879     $package = getfield $clogp, 'Source';
2880     build_maybe_quilt_fixup();
2881 }
2882
2883 sub cmd_archive_api_query {
2884     badusage "need only 1 subpath argument" unless @ARGV==1;
2885     my ($subpath) = @ARGV;
2886     my @cmd = archive_api_query_cmd($subpath);
2887     debugcmd ">",@cmd;
2888     exec @cmd or fail "exec curl: $!\n";
2889 }
2890
2891 sub cmd_clone_dgit_repos_server {
2892     badusage "need destination argument" unless @ARGV==1;
2893     my ($destdir) = @ARGV;
2894     $package = '_dgit-repos-server';
2895     my @cmd = (@git, qw(clone), access_giturl(), $destdir);
2896     debugcmd ">",@cmd;
2897     exec @cmd or fail "exec git clone: $!\n";
2898 }
2899
2900 sub cmd_setup_mergechangelogs {
2901     badusage "no arguments allowed to dgit setup-mergechangelogs" if @ARGV;
2902     setup_mergechangelogs();
2903 }
2904
2905 #---------- argument parsing and main program ----------
2906
2907 sub cmd_version {
2908     print "dgit version $our_version\n" or die $!;
2909     exit 0;
2910 }
2911
2912 sub parseopts () {
2913     my $om;
2914
2915     if (defined $ENV{'DGIT_SSH'}) {
2916         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
2917     } elsif (defined $ENV{'GIT_SSH'}) {
2918         @ssh = ($ENV{'GIT_SSH'});
2919     }
2920
2921     while (@ARGV) {
2922         last unless $ARGV[0] =~ m/^-/;
2923         $_ = shift @ARGV;
2924         last if m/^--?$/;
2925         if (m/^--/) {
2926             if (m/^--dry-run$/) {
2927                 push @ropts, $_;
2928                 $dryrun_level=2;
2929             } elsif (m/^--damp-run$/) {
2930                 push @ropts, $_;
2931                 $dryrun_level=1;
2932             } elsif (m/^--no-sign$/) {
2933                 push @ropts, $_;
2934                 $sign=0;
2935             } elsif (m/^--help$/) {
2936                 cmd_help();
2937             } elsif (m/^--version$/) {
2938                 cmd_version();
2939             } elsif (m/^--new$/) {
2940                 push @ropts, $_;
2941                 $new_package=1;
2942             } elsif (m/^--since-version=([^_]+|_)$/) {
2943                 push @ropts, $_;
2944                 $changes_since_version = $1;
2945             } elsif (m/^--([-0-9a-z]+)=(.*)/s &&
2946                      ($om = $opts_opt_map{$1}) &&
2947                      length $om->[0]) {
2948                 push @ropts, $_;
2949                 $om->[0] = $2;
2950             } elsif (m/^--([-0-9a-z]+):(.*)/s &&
2951                      !$opts_opt_cmdonly{$1} &&
2952                      ($om = $opts_opt_map{$1})) {
2953                 push @ropts, $_;
2954                 push @$om, $2;
2955             } elsif (m/^--existing-package=(.*)/s) {
2956                 push @ropts, $_;
2957                 $existing_package = $1;
2958             } elsif (m/^--initiator-tempdir=(.*)/s) {
2959                 $initiator_tempdir = $1;
2960                 $initiator_tempdir =~ m#^/# or
2961                     badusage "--initiator-tempdir must be used specify an".
2962                         " absolute, not relative, directory."
2963             } elsif (m/^--distro=(.*)/s) {
2964                 push @ropts, $_;
2965                 $idistro = $1;
2966             } elsif (m/^--build-products-dir=(.*)/s) {
2967                 push @ropts, $_;
2968                 $buildproductsdir = $1;
2969             } elsif (m/^--clean=(dpkg-source(?:-d)?|git|git-ff|check|none)$/s) {
2970                 push @ropts, $_;
2971                 $cleanmode = $1;
2972             } elsif (m/^--clean=(.*)$/s) {
2973                 badusage "unknown cleaning mode \`$1'";
2974             } elsif (m/^--quilt=($quilt_modes_re)$/s) {
2975                 push @ropts, $_;
2976                 $quilt_mode = $1;
2977             } elsif (m/^--quilt=(.*)$/s) {
2978                 badusage "unknown quilt fixup mode \`$1'";
2979             } elsif (m/^--ignore-dirty$/s) {
2980                 push @ropts, $_;
2981                 $ignoredirty = 1;
2982             } elsif (m/^--no-quilt-fixup$/s) {
2983                 push @ropts, $_;
2984                 $quilt_mode = 'nocheck';
2985             } elsif (m/^--no-rm-on-error$/s) {
2986                 push @ropts, $_;
2987                 $rmonerror = 0;
2988             } elsif (m/^--deliberately-($deliberately_re)$/s) {
2989                 push @ropts, $_;
2990                 push @deliberatelies, $&;
2991             } else {
2992                 badusage "unknown long option \`$_'";
2993             }
2994         } else {
2995             while (m/^-./s) {
2996                 if (s/^-n/-/) {
2997                     push @ropts, $&;
2998                     $dryrun_level=2;
2999                 } elsif (s/^-L/-/) {
3000                     push @ropts, $&;
3001                     $dryrun_level=1;
3002                 } elsif (s/^-h/-/) {
3003                     cmd_help();
3004                 } elsif (s/^-D/-/) {
3005                     push @ropts, $&;
3006                     $debuglevel++;
3007                     enabledebug();
3008                 } elsif (s/^-N/-/) {
3009                     push @ropts, $&;
3010                     $new_package=1;
3011                 } elsif (s/^-v([^_]+|_)$//s) {
3012                     push @ropts, $&;
3013                     $changes_since_version = $1;
3014                 } elsif (m/^-m/) {
3015                     push @ropts, $&;
3016                     push @changesopts, $_;
3017                     $_ = '';
3018                 } elsif (s/^-c(.*=.*)//s) {
3019                     push @ropts, $&;
3020                     push @git, '-c', $1;
3021                 } elsif (s/^-d(.+)//s) {
3022                     push @ropts, $&;
3023                     $idistro = $1;
3024                 } elsif (s/^-C(.+)//s) {
3025                     push @ropts, $&;
3026                     $changesfile = $1;
3027                     if ($changesfile =~ s#^(.*)/##) {
3028                         $buildproductsdir = $1;
3029                     }
3030                 } elsif (s/^-k(.+)//s) {
3031                     $keyid=$1;
3032                 } elsif (m/^-[vdCk]$/) {
3033                     badusage
3034  "option \`$_' requires an argument (and no space before the argument)";
3035                 } elsif (s/^-wn$//s) {
3036                     push @ropts, $&;
3037                     $cleanmode = 'none';
3038                 } elsif (s/^-wg$//s) {
3039                     push @ropts, $&;
3040                     $cleanmode = 'git';
3041                 } elsif (s/^-wgf$//s) {
3042                     push @ropts, $&;
3043                     $cleanmode = 'git-ff';
3044                 } elsif (s/^-wd$//s) {
3045                     push @ropts, $&;
3046                     $cleanmode = 'dpkg-source';
3047                 } elsif (s/^-wdd$//s) {
3048                     push @ropts, $&;
3049                     $cleanmode = 'dpkg-source-d';
3050                 } elsif (s/^-wc$//s) {
3051                     push @ropts, $&;
3052                     $cleanmode = 'check';
3053                 } else {
3054                     badusage "unknown short option \`$_'";
3055                 }
3056             }
3057         }
3058     }
3059 }
3060
3061 if ($ENV{$fakeeditorenv}) {
3062     quilt_fixup_editor();
3063 }
3064
3065 parseopts();
3066 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
3067 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
3068     if $dryrun_level == 1;
3069 if (!@ARGV) {
3070     print STDERR $helpmsg or die $!;
3071     exit 8;
3072 }
3073 my $cmd = shift @ARGV;
3074 $cmd =~ y/-/_/;
3075
3076 if (!defined $quilt_mode) {
3077     local $access_forpush;
3078     $quilt_mode = cfg('dgit.force.quilt-mode', 'RETURN-UNDEF')
3079         // access_cfg('quilt-mode', 'RETURN-UNDEF')
3080         // 'linear';
3081     $quilt_mode =~ m/^($quilt_modes_re)$/
3082         or badcfg "unknown quilt-mode \`$quilt_mode'";
3083     $quilt_mode = $1;
3084 }
3085
3086 my $fn = ${*::}{"cmd_$cmd"};
3087 $fn or badusage "unknown operation $cmd";
3088 $fn->();