dgit

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