dgit

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