dgit

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