dgit

   1 #!/usr/bin/perl -w
   2 # dgit
   3 # Integration between git and Debian-style archives
   4 #
   5 # Copyright (C)2013 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 IO::Handle;
  23 use Data::Dumper;
  24 use LWP::UserAgent;
  25 use Dpkg::Control::Hash;
  26 use File::Path;
  27 use File::Temp qw(tempdir);
  28 use File::Basename;
  29 use Dpkg::Version;
  30 use POSIX;
  31 use IPC::Open2;
  32
  33 our $our_version = 'UNRELEASED'; ###substituted###
  34
  35 our $isuite = 'unstable';
  36 our $idistro;
  37 our $package;
  38 our @ropts;
  39
  40 our $sign = 1;
  41 our $dryrun_level = 0;
  42 our $changesfile;
  43 our $new_package = 0;
  44 our $ignoredirty = 0;
  45 our $noquilt = 0;
  46 our $existing_package = 'dpkg';
  47 our $cleanmode = 'dpkg-source';
  48 our $we_are_responder;
  49
  50 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
  51
  52 our (@git) = qw(git);
  53 our (@dget) = qw(dget);
  54 our (@dput) = qw(dput);
  55 our (@debsign) = qw(debsign);
  56 our (@gpg) = qw(gpg);
  57 our (@sbuild) = qw(sbuild -A);
  58 our (@ssh) = 'ssh';
  59 our (@dgit) = qw(dgit);
  60 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
  61 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
  62 our (@dpkggenchanges) = qw(dpkg-genchanges);
  63 our (@mergechanges) = qw(mergechanges -f);
  64 our (@changesopts) = ('');
  65
  66 our %opts_opt_map = ('dget' => \@dget,
  67                      'dput' => \@dput,
  68                      'debsign' => \@debsign,
  69                      'gpg' => \@gpg,
  70                      'sbuild' => \@sbuild,
  71                      'ssh' => \@ssh,
  72                      'dgit' => \@dgit,
  73                      'dpkg-source' => \@dpkgsource,
  74                      'dpkg-buildpackage' => \@dpkgbuildpackage,
  75                      'dpkg-genchanges' => \@dpkggenchanges,
  76                      'ch' => \@changesopts,
  77                      'mergechanges' => \@mergechanges);
  78
  79 our %opts_opt_cmdonly = ('gpg' => 1);
  80
  81 our $keyid;
  82
  83 our $debug = 0;
  84 open DEBUG, ">/dev/null" or die $!;
  85
  86 autoflush STDOUT 1;
  87
  88 our $remotename = 'dgit';
  89 our @ourdscfield = qw(Dgit Vcs-Dgit-Master);
  90 our $branchprefix = 'dgit';
  91 our $csuite;
  92
  93 sub lbranch () { return "$branchprefix/$csuite"; }
  94 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
  95 sub lref () { return "refs/heads/".lbranch(); }
  96 sub lrref () { return "refs/remotes/$remotename/$branchprefix/$csuite"; }
  97 sub rrref () { return "refs/$branchprefix/$csuite"; }
  98 sub debiantag ($) {
  99     my ($v) = @_;
 100     $v =~ y/~:/_%/;
 101     return "debian/$v";
 102 }
 103
 104 sub stripepoch ($) {
 105     my ($vsn) = @_;
 106     $vsn =~ s/^\d+\://;
 107     return $vsn;
 108 }
 109
 110 sub dscfn ($) {
 111     my ($vsn) = @_;
 112     return "${package}_".(stripepoch $vsn).".dsc";
 113 }
 114
 115 sub changesopts () { return @changesopts[1..$#changesopts]; }
 116
 117 our $us = 'dgit';
 118 our $debugprefix = ' ';
 119
 120 sub printdebug { print DEBUG $debugprefix, @_ or die $!; }
 121
 122 sub fail { die "$us: @_\n"; }
 123
 124 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
 125
 126 sub no_such_package () {
 127     print STDERR "$us: package $package does not exist in suite $isuite\n";
 128     exit 4;
 129 }
 130
 131 sub fetchspec () {
 132     local $csuite = '*';
 133     return  "+".rrref().":".lrref();
 134 }
 135
 136 sub changedir ($) {
 137     my ($newdir) = @_;
 138     printdebug "CD $newdir\n";
 139     chdir $newdir or die "chdir: $newdir: $!";
 140 }
 141
 142 #---------- remote protocol support, common ----------
 143
 144 # remote push initiator/responder protocol:
 145 #  < dgit-remote-push-ready [optional extra info ignored by old initiators]
 146 #
 147 #  > file parsed-changelog
 148 #  [indicates that output of dpkg-parsechangelog follows]
 149 #  > data-block NBYTES
 150 #  > [NBYTES bytes of data (no newline)]
 151 #  [maybe some more blocks]
 152 #  > data-end
 153 #
 154 #  > file dsc
 155 #  [etc]
 156 #
 157 #  > file changes
 158 #  [etc]
 159 #
 160 #  > param head HEAD
 161 #
 162 #  > want signed-tag
 163 #  [indicates that signed tag is wanted]
 164 #  < data-block NBYTES
 165 #  < [NBYTES bytes of data (no newline)]
 166 #  [maybe some more blocks]
 167 #  < data-end
 168 #  < files-end
 169 #
 170 #  > want signed-dsc-changes
 171 #  < data-block NBYTES    [transfer of signed dsc]
 172 #  [etc]
 173 #  < data-block NBYTES    [transfer of signed changes]
 174 #  [etc]
 175 #  < files-end
 176 #
 177 #  > complete
 178
 179 sub badproto ($$) {
 180     my ($fh, $m) = @_;
 181     fail "connection lost: $!" if $fh->error;
 182     fail "connection terminated" if $fh->eof;
 183     fail "protocol violation; $m not expected";
 184 }
 185
 186 sub protocol_expect (&$) {
 187     my ($match, $fh) = @_;
 188     local $_;
 189     $_ = <$fh>;
 190     defined && chomp or badproto $fh, "eof";
 191     if (wantarray) {
 192         my @r = &$match;
 193         return @r if @r;
 194     } else {
 195         my $r = &$match;
 196         return $r if $r;
 197     }
 198     badproto $fh, "\`$_'";
 199 }
 200
 201 sub protocol_send_file ($$) {
 202     my ($fh, $ourfn) = @_;
 203     open PF, "<", $ourfn or die "$ourfn: $!";
 204     for (;;) {
 205         my $d;
 206         my $got = read PF, $d, 65536;
 207         die "$ourfn: $!" unless defined $got;
 208         last if $got;
 209         print $fh "data-block ".length($d)."\n" or die $!;
 210         print $d or die $!;
 211     }
 212     print $fh "data-end\n" or die $!;
 213     close PF;
 214 }
 215
 216 sub protocol_read_bytes ($$) {
 217     my ($fh, $nbytes) = @_;
 218     $nbytes =~ m/^\d{1,6}$/ or badproto \*RO, "bad byte count";
 219     my $d;
 220     my $got = read $fh, $d, $nbytes;
 221     $got==$nbytes or badproto $fh, "eof during data block";
 222     return $d;
 223 }
 224
 225 sub protocol_receive_file ($$) {
 226     my ($fh, $ourfn) = @_;
 227     open PF, ">", $ourfn or die "$ourfn: $!";
 228     for (;;) {
 229         my ($y,$l) = protocol_expect {
 230             m/^data-block (.*})$|data-end$/;
 231             length $1 ? (1,$1) : (0);
 232         } $fh;
 233         last unless $y;
 234         my $d = protocol_read_bytes $fh, $1;
 235         print PF $d or die $!;
 236     }
 237     printdebug "received into $ourfn\n";
 238 }
 239
 240 #---------- remote protocol support, responder ----------
 241
 242 sub responder_send_command ($) {
 243     my ($command) = @_;
 244     return unless $we_are_responder;
 245     # called even without $we_are_responder
 246     printdebug "<< $command\n";
 247     print $command, "\n" or die $!;
 248 }
 249
 250 sub responder_send_file ($$) {
 251     my ($keyword, $ourfn) = @_;
 252     return unless $we_are_responder;
 253     printdebug "[[ $keyword $ourfn\n";
 254     responder_send_command "file $keyword";
 255     protocol_send_file \*STDOUT, $ourfn;
 256 }
 257
 258 sub responder_receive_files ($@) {
 259     my ($keyword, @ourfns) = @_;
 260     die unless $we_are_responder;
 261     printdebug "]] $keyword @ourfns\n";
 262     responder_send_command "want $keyword";
 263     foreach my $fn (@ourfns) {
 264         protocol_receive_file \*STDIN, $fn;
 265     }
 266     protocol_expect { m/^files-end$/ } \*STDIN;
 267 }
 268
 269 #---------- remote protocol support, initiator ----------
 270
 271 sub initiator_expect (&) {
 272     my ($match) = @_;
 273     protocol_expect { &$match } \*RO;
 274 }
 275
 276 #---------- end remote code ----------
 277
 278 sub progress {
 279     if ($we_are_responder) {
 280         my $m = join '', @_;
 281         responder_send_command "progress ".length($m) or die $!;
 282         print $m or die $!;
 283     } else {
 284         print @_, "\n";
 285     }
 286 }
 287
 288 our $ua;
 289
 290 sub url_get {
 291     if (!$ua) {
 292         $ua = LWP::UserAgent->new();
 293         $ua->env_proxy;
 294     }
 295     my $what = $_[$#_];
 296     progress "downloading $what...";
 297     my $r = $ua->get(@_) or die $!;
 298     return undef if $r->code == 404;
 299     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
 300     return $r->decoded_content();
 301 }
 302
 303 our ($dscdata,$dscurl,$dsc,$skew_warning_vsn);
 304
 305 sub shellquote {
 306     my @out;
 307     local $_;
 308     foreach my $a (@_) {
 309         $_ = $a;
 310         if (s{['\\]}{\\$&}g || m{\s} || m{[^-_./0-9a-z]}i) {
 311             push @out, "'$_'";
 312         } else {
 313             push @out, $_;
 314         }
 315     }
 316     return join ' ', @out;
 317 }
 318
 319 sub printcmd {
 320     my $fh = shift @_;
 321     my $intro = shift @_;
 322     print $fh $intro," " or die $!;
 323     print $fh shellquote @_ or die $!;
 324     print $fh "\n" or die $!;
 325 }
 326
 327 sub failedcmd {
 328     { local ($!); printcmd \*STDERR, "$_[0]: failed command:", @_ or die $!; };
 329     if ($!) {
 330         fail "failed to fork/exec: $!";
 331     } elsif (!($? & 0xff)) {
 332         fail "subprocess failed with error exit status ".($?>>8);
 333     } elsif ($?) {
 334         fail "subprocess crashed (wait status $?)";
 335     } else {
 336         fail "subprocess produced invalid output";
 337     }
 338 }
 339
 340 sub runcmd {
 341     printcmd(\*DEBUG,$debugprefix."+",@_) if $debug>0;
 342     $!=0; $?=0;
 343     failedcmd @_ if system @_;
 344 }
 345
 346 sub act_local () { return $dryrun_level <= 1; }
 347 sub act_scary () { return !$dryrun_level; }
 348
 349 sub printdone {
 350     if (!$dryrun_level) {
 351         progress "dgit ok: @_";
 352     } else {
 353         progress "would be ok: @_ (but dry run only)";
 354     }
 355 }
 356
 357 sub cmdoutput_errok {
 358     die Dumper(\@_)." ?" if grep { !defined } @_;
 359     printcmd(\*DEBUG,$debugprefix."|",@_) if $debug>0;
 360     open P, "-|", @_ or die $!;
 361     my $d;
 362     $!=0; $?=0;
 363     { local $/ = undef; $d = <P>; }
 364     die $! if P->error;
 365     if (!close P) { printdebug "=>!$?\n" if $debug>0; return undef; }
 366     chomp $d;
 367     $d =~ m/^.*/;
 368     printdebug "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #';
 369     return $d;
 370 }
 371
 372 sub cmdoutput {
 373     my $d = cmdoutput_errok @_;
 374     defined $d or failedcmd @_;
 375     return $d;
 376 }
 377
 378 sub dryrun_report {
 379     printcmd(\*STDERR,$debugprefix."#",@_);
 380 }
 381
 382 sub runcmd_ordryrun {
 383     if (act_scary()) {
 384         runcmd @_;
 385     } else {
 386         dryrun_report @_;
 387     }
 388 }
 389
 390 sub runcmd_ordryrun_local {
 391     if (act_local()) {
 392         runcmd @_;
 393     } else {
 394         dryrun_report @_;
 395     }
 396 }
 397
 398 sub shell_cmd {
 399     my ($first_shell, @cmd) = @_;
 400     return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
 401 }
 402
 403 our $helpmsg = <<END;
 404 main usages:
 405   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
 406   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
 407   dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
 408   dgit [dgit-opts] push [dgit-opts] [suite]
 409   dgit [dgit-opts] rpush build-host:build-dir ...
 410 important dgit options:
 411   -k<keyid>           sign tag and package with <keyid> instead of default
 412   --dry-run -n        do not change anything, but go through the motions
 413   --damp-run -L       like --dry-run but make local changes, without signing
 414   --new -N            allow introducing a new package
 415   --debug -D          increase debug level
 416   -c<name>=<value>    set git config option (used directly by dgit too)
 417 END
 418
 419 our $later_warning_msg = <<END;
 420 Perhaps the upload is stuck in incoming.  Using the version from git.
 421 END
 422
 423 sub badusage {
 424     print STDERR "$us: @_\n", $helpmsg or die $!;
 425     exit 8;
 426 }
 427
 428 sub nextarg {
 429     @ARGV or badusage "too few arguments";
 430     return scalar shift @ARGV;
 431 }
 432
 433 sub cmd_help () {
 434     print $helpmsg or die $!;
 435     exit 0;
 436 }
 437
 438 our %defcfg = ('dgit.default.distro' => 'debian',
 439                'dgit.default.username' => '',
 440                'dgit.default.archive-query-default-component' => 'main',
 441                'dgit.default.ssh' => 'ssh',
 442                'dgit-distro.debian.git-host' => 'git.debian.org',
 443                'dgit-distro.debian.git-proto' => 'git+ssh://',
 444                'dgit-distro.debian.git-path' => '/git/dgit-repos/repos',
 445                'dgit-distro.debian.git-check' => 'ssh-cmd',
 446                'dgit-distro.debian.git-create' => 'ssh-cmd',
 447                'dgit-distro.debian.sshdakls-host' => 'coccia.debian.org',
 448                'dgit-distro.debian.sshdakls-dir' =>
 449                    '/srv/ftp-master.debian.org/ftp/dists',
 450                'dgit-distro.debian.upload-host' => 'ftp-master', # for dput
 451                'dgit-distro.debian.mirror' => 'http://ftp.debian.org/debian/');
 452
 453 sub cfg {
 454     foreach my $c (@_) {
 455         return undef if $c =~ /RETURN-UNDEF/;
 456         my @cmd = (@git, qw(config --), $c);
 457         my $v;
 458         {
 459             local ($debug) = $debug-1;
 460             $v = cmdoutput_errok @cmd;
 461         };
 462         if ($?==0) {
 463             return $v;
 464         } elsif ($?!=256) {
 465             failedcmd @cmd;
 466         }
 467         my $dv = $defcfg{$c};
 468         return $dv if defined $dv;
 469     }
 470     badcfg "need value for one of: @_";
 471 }
 472
 473 sub access_distro () {
 474     return cfg("dgit-suite.$isuite.distro",
 475                "dgit.default.distro");
 476 }
 477
 478 sub access_cfg (@) {
 479     my (@keys) = @_;
 480     my $distro = $idistro || access_distro();
 481     my $value = cfg(map { ("dgit-distro.$distro.$_",
 482                            "dgit.default.$_") } @keys);
 483     return $value;
 484 }
 485
 486 sub string_to_ssh ($) {
 487     my ($spec) = @_;
 488     if ($spec =~ m/\s/) {
 489         return qw(sh -ec), 'exec '.$spec.' "$@"', 'x';
 490     } else {
 491         return ($spec);
 492     }
 493 }
 494
 495 sub access_cfg_ssh () {
 496     my $gitssh = access_cfg('ssh', 'RETURN-UNDEF');
 497     if (!defined $gitssh) {
 498         return @ssh;
 499     } else {
 500         return string_to_ssh $gitssh;
 501     }
 502 }
 503
 504 sub access_someuserhost ($) {
 505     my ($some) = @_;
 506     my $user = access_cfg("$some-user",'username');
 507     my $host = access_cfg("$some-host");
 508     return length($user) ? "$user\@$host" : $host;
 509 }
 510
 511 sub access_gituserhost () {
 512     return access_someuserhost('git');
 513 }
 514
 515 sub access_giturl () {
 516     my $url = access_cfg('git-url','RETURN-UNDEF');
 517     if (!defined $url) {
 518         $url =
 519             access_cfg('git-proto').
 520             access_gituserhost().
 521             access_cfg('git-path');
 522     }
 523     return "$url/$package.git";
 524 }
 525
 526 sub parsecontrolfh ($$@) {
 527     my ($fh, $desc, @opts) = @_;
 528     my %opts = ('name' => $desc, @opts);
 529     my $c = Dpkg::Control::Hash->new(%opts);
 530     $c->parse($fh) or die "parsing of $desc failed";
 531     return $c;
 532 }
 533
 534 sub parsecontrol {
 535     my ($file, $desc) = @_;
 536     my $fh = new IO::Handle;
 537     open $fh, '<', $file or die "$file: $!";
 538     my $c = parsecontrolfh($fh,$desc);
 539     $fh->error and die $!;
 540     close $fh;
 541     return $c;
 542 }
 543
 544 sub getfield ($$) {
 545     my ($dctrl,$field) = @_;
 546     my $v = $dctrl->{$field};
 547     return $v if defined $v;
 548     fail "missing field $field in ".$v->get_option('name');
 549 }
 550
 551 sub parsechangelog {
 552     my $c = Dpkg::Control::Hash->new();
 553     my $p = new IO::Handle;
 554     my @cmd = (qw(dpkg-parsechangelog), @_);
 555     open $p, '-|', @cmd or die $!;
 556     $c->parse($p);
 557     $?=0; $!=0; close $p or failedcmd @cmd;
 558     return $c;
 559 }
 560
 561 our %rmad;
 562
 563 sub archive_query ($) {
 564     my ($method) = @_;
 565     my $query = access_cfg('archive-query','RETURN-UNDEF');
 566     if (!defined $query) {
 567         my $distro = access_distro();
 568         if ($distro eq 'debian') {
 569             $query = "sshdakls:".
 570                 access_someuserhost('sshdakls').':'.
 571                 access_cfg('sshdakls-dir');
 572         } else {
 573             $query = "madison:$distro";
 574         }
 575     }
 576     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
 577     my $proto = $1;
 578     my $data = $'; #';
 579     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
 580 }
 581
 582 sub archive_query_madison ($$) {
 583     my ($proto,$data) = @_;
 584     die unless $proto eq 'madison';
 585     $rmad{$package} ||= cmdoutput
 586         qw(rmadison -asource),"-s$isuite","-u$data",$package;
 587     my $rmad = $rmad{$package};
 588     return madison_parse($rmad);
 589 }
 590
 591 sub archive_query_sshdakls ($$) {
 592     my ($proto,$data) = @_;
 593     $data =~ s/:.*// or badcfg "invalid sshdakls method string \`$data'";
 594     my $dakls = cmdoutput
 595         access_cfg_ssh, $data, qw(dak ls -asource),"-s$isuite",$package;
 596     return madison_parse($dakls);
 597 }
 598
 599 sub canonicalise_suite_sshdakls ($$) {
 600     my ($proto,$data) = @_;
 601     $data =~ m/:/ or badcfg "invalid sshdakls method string \`$data'";
 602     my @cmd =
 603         (access_cfg_ssh, $`,
 604          "set -e; cd $';".
 605          " if test -h $isuite; then readlink $isuite; exit 0; fi;".
 606          " if test -d $isuite; then echo $isuite; exit 0; fi;".
 607          " exit 1");
 608     my $dakls = cmdoutput @cmd;
 609     failedcmd @cmd unless $dakls =~ m/^\w/;
 610     return $dakls;
 611 }
 612
 613 sub madison_parse ($) {
 614     my ($rmad) = @_;
 615     my @out;
 616     foreach my $l (split /\n/, $rmad) {
 617         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
 618                   \s*( [^ \t|]+ )\s* \|
 619                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
 620                   \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
 621         $1 eq $package or die "$rmad $package ?";
 622         my $vsn = $2;
 623         my $newsuite = $3;
 624         my $component;
 625         if (defined $4) {
 626             $component = $4;
 627         } else {
 628             $component = access_cfg('archive-query-default-component');
 629         }
 630         $5 eq 'source' or die "$rmad ?";
 631         my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
 632         my $subpath = "/pool/$component/$prefix/$package/".dscfn($vsn);
 633         push @out, [$vsn,$subpath,$newsuite];
 634     }
 635     return sort { -version_compare_string($a->[0],$b->[0]); } @out;
 636 }
 637
 638 sub canonicalise_suite_madison ($$) {
 639     my @r = archive_query_madison($_[0],$_[1]);
 640     @r or fail
 641         "unable to canonicalise suite using package $package".
 642         " which does not appear to exist in suite $isuite;".
 643         " --existing-package may help";
 644     return $r[0][2];
 645 }
 646
 647 sub canonicalise_suite () {
 648     return if defined $csuite;
 649     fail "cannot operate on $isuite suite" if $isuite eq 'UNRELEASED';
 650     $csuite = archive_query('canonicalise_suite');
 651     if ($isuite ne $csuite) {
 652         # madison canonicalises for us
 653         progress "canonical suite name for $isuite is $csuite";
 654     }
 655 }
 656
 657 sub get_archive_dsc () {
 658     canonicalise_suite();
 659     my @vsns = archive_query('archive_query');
 660     foreach my $vinfo (@vsns) {
 661         my ($vsn,$subpath) = @$vinfo;
 662         $dscurl = access_cfg('mirror').$subpath;
 663         $dscdata = url_get($dscurl);
 664         if (!$dscdata) {
 665             $skew_warning_vsn = $vsn if !defined $skew_warning_vsn;
 666             next;
 667         }
 668         my $dscfh = new IO::File \$dscdata, '<' or die $!;
 669         printdebug Dumper($dscdata) if $debug>1;
 670         $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1);
 671         printdebug Dumper($dsc) if $debug>1;
 672         my $fmt = getfield $dsc, 'Format';
 673         fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
 674         return;
 675     }
 676     $dsc = undef;
 677 }
 678
 679 sub check_for_git () {
 680     # returns 0 or 1
 681     my $how = access_cfg('git-check');
 682     if ($how eq 'ssh-cmd') {
 683         my @cmd =
 684             (access_cfg_ssh, access_gituserhost(),
 685              " set -e; cd ".access_cfg('git-path').";".
 686              " if test -d $package.git; then echo 1; else echo 0; fi");
 687         my $r= cmdoutput @cmd;
 688         failedcmd @cmd unless $r =~ m/^[01]$/;
 689         return $r+0;
 690     } else {
 691         badcfg "unknown git-check \`$how'";
 692     }
 693 }
 694
 695 sub create_remote_git_repo () {
 696     my $how = access_cfg('git-create');
 697     if ($how eq 'ssh-cmd') {
 698         runcmd_ordryrun
 699             (access_cfg_ssh, access_gituserhost(),
 700              "set -e; cd ".access_cfg('git-path').";".
 701              " cp -a _template $package.git");
 702     } else {
 703         badcfg "unknown git-create \`$how'";
 704     }
 705 }
 706
 707 our ($dsc_hash,$lastpush_hash);
 708
 709 our $ud = '.git/dgit/unpack';
 710
 711 sub prep_ud () {
 712     rmtree($ud);
 713     mkpath '.git/dgit';
 714     mkdir $ud or die $!;
 715 }
 716
 717 sub mktree_in_ud_from_only_subdir () {
 718     # changes into the subdir
 719     my (@dirs) = <*/.>;
 720     die unless @dirs==1;
 721     $dirs[0] =~ m#^([^/]+)/\.$# or die;
 722     my $dir = $1;
 723     changedir $dir;
 724     fail "source package contains .git directory" if stat '.git';
 725     die $! unless $!==&ENOENT;
 726     runcmd qw(git init -q);
 727     rmtree('.git/objects');
 728     symlink '../../../../objects','.git/objects' or die $!;
 729     runcmd @git, qw(add -Af);
 730     my $tree = cmdoutput @git, qw(write-tree);
 731     $tree =~ m/^\w+$/ or die "$tree ?";
 732     return ($tree,$dir);
 733 }
 734
 735 sub dsc_files_info () {
 736     foreach my $csumi (['Checksums-Sha256','Digest::SHA', 'new(256)'],
 737                        ['Checksums-Sha1',  'Digest::SHA', 'new(1)'],
 738                        ['Files',           'Digest::MD5', 'new()']) {
 739         my ($fname, $module, $method) = @$csumi;
 740         my $field = $dsc->{$fname};
 741         next unless defined $field;
 742         eval "use $module; 1;" or die $@;
 743         my @out;
 744         foreach (split /\n/, $field) {
 745             next unless m/\S/;
 746             m/^(\w+) (\d+) (\S+)$/ or
 747                 fail "could not parse .dsc $fname line \`$_'";
 748             my $digester = eval "$module"."->$method;" or die $@;
 749             push @out, {
 750                 Hash => $1,
 751                 Bytes => $2,
 752                 Filename => $3,
 753                 Digester => $digester,
 754             };
 755         }
 756         return @out;
 757     }
 758     fail "missing any supported Checksums-* or Files field in ".
 759         $dsc->get_option('name');
 760 }
 761
 762 sub dsc_files () {
 763     map { $_->{Filename} } dsc_files_info();
 764 }
 765
 766 sub is_orig_file ($) {
 767     local ($_) = @_;
 768     m/\.orig(?:-\w+)?\.tar\.\w+$/;
 769 }
 770
 771 sub make_commit ($) {
 772     my ($file) = @_;
 773     return cmdoutput @git, qw(hash-object -w -t commit), $file;
 774 }
 775
 776 sub clogp_authline ($) {
 777     my ($clogp) = @_;
 778     my $author = getfield $clogp, 'Maintainer';
 779     $author =~ s#,.*##ms;
 780     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
 781     my $authline = "$author $date";
 782     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
 783         fail "unexpected commit author line format \`$authline'".
 784         " (was generated from changelog Maintainer field)";
 785     return $authline;
 786 }
 787
 788 sub generate_commit_from_dsc () {
 789     prep_ud();
 790     changedir $ud;
 791     my @files;
 792     foreach my $f (dsc_files()) {
 793         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
 794         push @files, $f;
 795         link "../../../$f", $f
 796             or $!==&ENOENT
 797             or die "$f $!";
 798     }
 799     runcmd @dget, qw(--), $dscurl;
 800     foreach my $f (grep { is_orig_file($_) } @files) {
 801         link $f, "../../../../$f"
 802             or $!==&EEXIST
 803             or die "$f $!";
 804     }
 805     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
 806     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
 807     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
 808     my $authline = clogp_authline $clogp;
 809     my $changes = getfield $clogp, 'Changes';
 810     open C, ">../commit.tmp" or die $!;
 811     print C <<END or die $!;
 812 tree $tree
 813 author $authline
 814 committer $authline
 815
 816 $changes
 817
 818 # imported from the archive
 819 END
 820     close C or die $!;
 821     my $outputhash = make_commit qw(../commit.tmp);
 822     my $cversion = getfield $clogp, 'Version';
 823     progress "synthesised git commit from .dsc $cversion";
 824     if ($lastpush_hash) {
 825         runcmd @git, qw(reset --hard), $lastpush_hash;
 826         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
 827         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
 828         my $oversion = getfield $oldclogp, 'Version';
 829         my $vcmp =
 830             version_compare_string($oversion, $cversion);
 831         if ($vcmp < 0) {
 832             # git upload/ is earlier vsn than archive, use archive
 833             open C, ">../commit2.tmp" or die $!;
 834             print C <<END or die $!;
 835 tree $tree
 836 parent $lastpush_hash
 837 parent $outputhash
 838 author $authline
 839 committer $authline
 840
 841 Record $package ($cversion) in archive suite $csuite
 842 END
 843             $outputhash = make_commit qw(../commit2.tmp);
 844         } elsif ($vcmp > 0) {
 845             print STDERR <<END or die $!;
 846
 847 Version actually in archive:    $cversion (older)
 848 Last allegedly pushed/uploaded: $oversion (newer or same)
 849 $later_warning_msg
 850 END
 851             $outputhash = $lastpush_hash;
 852         } else {
 853             $outputhash = $lastpush_hash;
 854         }
 855     }
 856     changedir '../../../..';
 857     runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
 858             'DGIT_ARCHIVE', $outputhash;
 859     cmdoutput @git, qw(log -n2), $outputhash;
 860     # ... gives git a chance to complain if our commit is malformed
 861     rmtree($ud);
 862     return $outputhash;
 863 }
 864
 865 sub ensure_we_have_orig () {
 866     foreach my $fi (dsc_files_info()) {
 867         my $f = $fi->{Filename};
 868         next unless is_orig_file($f);
 869         if (open F, "<", "../$f") {
 870             $fi->{Digester}->reset();
 871             $fi->{Digester}->addfile(*F);
 872             F->error and die $!;
 873             my $got = $fi->{Digester}->hexdigest();
 874             $got eq $fi->{Hash} or
 875                 fail "existing file $f has hash $got but .dsc".
 876                     " demands hash $fi->{Hash}".
 877                     " (perhaps you should delete this file?)";
 878             progress "using existing $f";
 879             next;
 880         } else {
 881             die "$f $!" unless $!==&ENOENT;
 882         }
 883         my $origurl = $dscurl;
 884         $origurl =~ s{/[^/]+$}{};
 885         $origurl .= "/$f";
 886         die "$f ?" unless $f =~ m/^${package}_/;
 887         die "$f ?" if $f =~ m#/#;
 888         runcmd_ordryrun_local shell_cmd 'cd ..', @dget,'--',$origurl;
 889     }
 890 }
 891
 892 sub rev_parse ($) {
 893     return cmdoutput @git, qw(rev-parse), "$_[0]~0";
 894 }
 895
 896 sub is_fast_fwd ($$) {
 897     my ($ancestor,$child) = @_;
 898     my @cmd = (@git, qw(merge-base), $ancestor, $child);
 899     my $mb = cmdoutput_errok @cmd;
 900     if (defined $mb) {
 901         return rev_parse($mb) eq rev_parse($ancestor);
 902     } else {
 903         $?==256 or failedcmd @cmd;
 904         return 0;
 905     }
 906 }
 907
 908 sub git_fetch_us () {
 909     runcmd_ordryrun_local @git, qw(fetch),access_giturl(),fetchspec();
 910 }
 911
 912 sub fetch_from_archive () {
 913     # ensures that lrref() is what is actually in the archive,
 914     #  one way or another
 915     get_archive_dsc();
 916
 917     if ($dsc) {
 918         foreach my $field (@ourdscfield) {
 919             $dsc_hash = $dsc->{$field};
 920             last if defined $dsc_hash;
 921         }
 922         if (defined $dsc_hash) {
 923             $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
 924             $dsc_hash = $&;
 925             progress "last upload to archive specified git hash";
 926         } else {
 927             progress "last upload to archive has NO git hash";
 928         }
 929     } else {
 930         progress "no version available from the archive";
 931     }
 932
 933     my $lrref_fn = ".git/".lrref();
 934     if (open H, $lrref_fn) {
 935         $lastpush_hash = <H>;
 936         chomp $lastpush_hash;
 937         die "$lrref_fn $lastpush_hash ?" unless $lastpush_hash =~ m/^\w+$/;
 938     } elsif ($! == &ENOENT) {
 939         $lastpush_hash = '';
 940     } else {
 941         die "$lrref_fn $!";
 942     }
 943     printdebug "previous reference hash=$lastpush_hash\n";
 944     my $hash;
 945     if (defined $dsc_hash) {
 946         fail "missing git history even though dsc has hash -".
 947             " could not find commit $dsc_hash".
 948             " (should be in ".access_giturl()."#".rrref().")"
 949             unless $lastpush_hash;
 950         $hash = $dsc_hash;
 951         ensure_we_have_orig();
 952         if ($dsc_hash eq $lastpush_hash) {
 953         } elsif (is_fast_fwd($dsc_hash,$lastpush_hash)) {
 954             print STDERR <<END or die $!;
 955
 956 Git commit in archive is behind the last version allegedly pushed/uploaded.
 957 Commit referred to by archive:  $dsc_hash
 958 Last allegedly pushed/uploaded: $lastpush_hash
 959 $later_warning_msg
 960 END
 961             $hash = $lastpush_hash;
 962         } else {
 963             fail "archive's .dsc refers to ".$dsc_hash.
 964                 " but this is an ancestor of ".$lastpush_hash;
 965         }
 966     } elsif ($dsc) {
 967         $hash = generate_commit_from_dsc();
 968     } elsif ($lastpush_hash) {
 969         # only in git, not in the archive yet
 970         $hash = $lastpush_hash;
 971         print STDERR <<END or die $!;
 972
 973 Package not found in the archive, but has allegedly been pushed using dgit.
 974 $later_warning_msg
 975 END
 976     } else {
 977         printdebug "nothing found!\n";
 978         if (defined $skew_warning_vsn) {
 979             print STDERR <<END or die $!;
 980
 981 Warning: relevant archive skew detected.
 982 Archive allegedly contains $skew_warning_vsn
 983 But we were not able to obtain any version from the archive or git.
 984
 985 END
 986         }
 987         return 0;
 988     }
 989     printdebug "current hash=$hash\n";
 990     if ($lastpush_hash) {
 991         fail "not fast forward on last upload branch!".
 992             " (archive's version left in DGIT_ARCHIVE)"
 993             unless is_fast_fwd($lastpush_hash, $hash);
 994     }
 995     if (defined $skew_warning_vsn) {
 996         mkpath '.git/dgit';
 997         printdebug "SKEW CHECK WANT $skew_warning_vsn\n";
 998         my $clogf = ".git/dgit/changelog.tmp";
 999         runcmd shell_cmd "exec >$clogf",
1000             @git, qw(cat-file blob), "$hash:debian/changelog";
1001         my $gotclogp = parsechangelog("-l$clogf");
1002         my $got_vsn = getfield $gotclogp, 'Version';
1003         printdebug "SKEW CHECK GOT $got_vsn\n";
1004         if (version_compare_string($got_vsn, $skew_warning_vsn) < 0) {
1005             print STDERR <<END or die $!;
1006
1007 Warning: archive skew detected.  Using the available version:
1008 Archive allegedly contains    $skew_warning_vsn
1009 We were able to obtain only   $got_vsn
1010
1011 END
1012         }
1013     }
1014     if ($lastpush_hash ne $hash) {
1015         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
1016         if (act_local()) {
1017             cmdoutput @upd_cmd;
1018         } else {
1019             dryrun_report @upd_cmd;
1020         }
1021     }
1022     return 1;
1023 }
1024
1025 sub clone ($) {
1026     my ($dstdir) = @_;
1027     canonicalise_suite();
1028     badusage "dry run makes no sense with clone" unless act_local();
1029     mkdir $dstdir or die "$dstdir $!";
1030     changedir $dstdir;
1031     runcmd @git, qw(init -q);
1032     runcmd @git, qw(config), "remote.$remotename.fetch", fetchspec();
1033     open H, "> .git/HEAD" or die $!;
1034     print H "ref: ".lref()."\n" or die $!;
1035     close H or die $!;
1036     runcmd @git, qw(remote add), 'origin', access_giturl();
1037     if (check_for_git()) {
1038         progress "fetching existing git history";
1039         git_fetch_us();
1040         runcmd_ordryrun_local @git, qw(fetch origin);
1041     } else {
1042         progress "starting new git history";
1043     }
1044     fetch_from_archive() or no_such_package;
1045     runcmd @git, qw(reset --hard), lrref();
1046     printdone "ready for work in $dstdir";
1047 }
1048
1049 sub fetch () {
1050     if (check_for_git()) {
1051         git_fetch_us();
1052     }
1053     fetch_from_archive() or no_such_package();
1054     printdone "fetched into ".lrref();
1055 }
1056
1057 sub pull () {
1058     fetch();
1059     runcmd_ordryrun_local @git, qw(merge -m),"Merge from $csuite [dgit]",
1060         lrref();
1061     printdone "fetched to ".lrref()." and merged into HEAD";
1062 }
1063
1064 sub check_not_dirty () {
1065     return if $ignoredirty;
1066     my @cmd = (@git, qw(diff --quiet HEAD));
1067     printcmd(\*DEBUG,$debugprefix."+",@cmd) if $debug>0;
1068     $!=0; $?=0; system @cmd;
1069     return if !$! && !$?;
1070     if (!$! && $?==256) {
1071         fail "working tree is dirty (does not match HEAD)";
1072     } else {
1073         failedcmd @cmd;
1074     }
1075 }
1076
1077 sub commit_quilty_patch () {
1078     my $output = cmdoutput @git, qw(status --porcelain);
1079     my %adds;
1080     foreach my $l (split /\n/, $output) {
1081         next unless $l =~ m/\S/;
1082         if ($l =~ m{^(?:\?\?| M) (.pc|debian/patches)}) {
1083             $adds{$1}++;
1084         }
1085     }
1086     if (!%adds) {
1087         progress "nothing quilty to commit, ok.";
1088         return;
1089     }
1090     runcmd_ordryrun_local @git, qw(add), sort keys %adds;
1091     my $m = "Commit Debian 3.0 (quilt) metadata";
1092     progress "$m";
1093     runcmd_ordryrun_local @git, qw(commit -m), $m;
1094 }
1095
1096 sub madformat ($) {
1097     my ($format) = @_;
1098     return 0 unless $format eq '3.0 (quilt)';
1099     progress "Format \`$format', urgh";
1100     if ($noquilt) {
1101         progress "Not doing any fixup of \`$format' due to --no-quilt-fixup";
1102         return 0;
1103     }
1104     return 1;
1105 }
1106
1107 sub push_parse_changelog ($) {
1108     my ($clogpfn) = @_;
1109
1110     my $clogp = Dpkg::Control::Hash->new();
1111     $clogp->load($clogpfn);
1112
1113     $package = getfield $clogp, 'Source';
1114     my $cversion = getfield $clogp, 'Version';
1115     my $tag = debiantag($cversion);
1116     runcmd @git, qw(check-ref-format), $tag;
1117
1118     my $dscfn = dscfn($cversion);
1119
1120     return ($clogp, $cversion, $tag, $dscfn);
1121 }
1122
1123 sub push_parse_dsc ($$$) {
1124     my ($dscfn,$dscfnwhat, $cversion) = @_;
1125     $dsc = parsecontrol($dscfn,$dscfnwhat);
1126     my $dversion = getfield $dsc, 'Version';
1127     my $dscpackage = getfield $dsc, 'Source';
1128     ($dscpackage eq $package && $dversion eq $cversion) or
1129         fail "$dsc is for $dscpackage $dversion".
1130             " but debian/changelog is for $package $cversion";
1131 }
1132
1133 sub push_mktag ($$$$$$$$) {
1134     my ($head,$clogp,$tag,
1135         $dsc,$dscfn,
1136         $changesfile,$changesfilewhat,
1137         $tfn) = @_;
1138
1139     $dsc->{$ourdscfield[0]} = $head;
1140     $dsc->save("$dscfn.tmp") or die $!;
1141
1142     my $changes = parsecontrol($changesfile,$changesfilewhat);
1143     foreach my $field (qw(Source Distribution Version)) {
1144         $changes->{$field} eq $clogp->{$field} or
1145             fail "changes field $field \`$changes->{$field}'".
1146                 " does not match changelog \`$clogp->{$field}'";
1147     }
1148
1149     my $cversion = getfield $clogp, 'Version';
1150
1151     # We make the git tag by hand because (a) that makes it easier
1152     # to control the "tagger" (b) we can do remote signing
1153     my $authline = clogp_authline $clogp;
1154     open TO, '>', $tfn->('.tmp') or die $!;
1155     print TO <<END or die $!;
1156 object $head
1157 type commit
1158 tag $tag
1159 tagger $authline
1160
1161 $package release $cversion for $csuite [dgit]
1162 END
1163     close TO or die $!;
1164
1165     my $tagobjfn = $tfn->('.tmp');
1166     if ($sign) {
1167         if (!defined $keyid) {
1168             $keyid = access_cfg('keyid','RETURN-UNDEF');
1169         }
1170         unlink $tfn->('.tmp.asc') or $!==&ENOENT or die $!;
1171         my @sign_cmd = (@gpg, qw(--detach-sign --armor));
1172         push @sign_cmd, qw(-u),$keyid if defined $keyid;
1173         push @sign_cmd, $tfn->('.tmp');
1174         runcmd_ordryrun @sign_cmd;
1175         if (act_scary()) {
1176             $tagobjfn = $tfn->('.signed.tmp');
1177             runcmd shell_cmd "exec >$tagobjfn", qw(cat --),
1178                 $tfn->('.tmp'), $tfn->('.tmp.asc');
1179         }
1180     }
1181
1182     return ($tagobjfn);
1183 }
1184
1185 sub sign_changes ($) {
1186     my ($changesfile) = @_;
1187     if ($sign) {
1188         my @debsign_cmd = @debsign;
1189         push @debsign_cmd, "-k$keyid" if defined $keyid;
1190         push @debsign_cmd, "-p$gpg[0]" if $gpg[0] ne 'gpg';
1191         push @debsign_cmd, $changesfile;
1192         runcmd_ordryrun @debsign_cmd;
1193     }
1194 }
1195
1196 sub dopush () {
1197     printdebug "actually entering push\n";
1198     prep_ud();
1199
1200     my $clogpfn = ".git/dgit/changelog.822.tmp";
1201     runcmd shell_cmd "exec >$clogpfn", qw(dpkg-parsechangelog);
1202
1203     responder_send_file('parsed-changelog', $clogpfn);
1204
1205     my ($clogp, $cversion, $tag, $dscfn) =
1206         push_parse_changelog("$clogpfn");
1207
1208     stat "../$dscfn" or
1209         fail "looked for .dsc $dscfn, but $!;".
1210             " maybe you forgot to build";
1211
1212     responder_send_file('dsc', "../$dscfn");
1213
1214     push_parse_dsc("../$dscfn", $dscfn, $cversion);
1215
1216     my $format = getfield $dsc, 'Format';
1217     printdebug "format $format\n";
1218     if (madformat($format)) {
1219         commit_quilty_patch();
1220     }
1221     check_not_dirty();
1222     changedir $ud;
1223     progress "checking that $dscfn corresponds to HEAD";
1224     runcmd qw(dpkg-source -x --), "../../../../$dscfn";
1225     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
1226     changedir '../../../..';
1227     my @diffcmd = (@git, qw(diff --exit-code), $tree);
1228     printcmd \*DEBUG,$debugprefix."+",@diffcmd;
1229     $!=0; $?=0;
1230     if (system @diffcmd) {
1231         if ($! && $?==256) {
1232             fail "$dscfn specifies a different tree to your HEAD commit;".
1233                 " perhaps you forgot to build";
1234         } else {
1235             failedcmd @diffcmd;
1236         }
1237     }
1238 #fetch from alioth
1239 #do fast forward check and maybe fake merge
1240 #    if (!is_fast_fwd(mainbranch
1241 #    runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
1242 #        map { lref($_).":".rref($_) }
1243 #        (uploadbranch());
1244     my $head = rev_parse('HEAD');
1245     if (!$changesfile) {
1246         my $multi = "../${package}_".(stripepoch $cversion)."_multi.changes";
1247         if (stat "$multi") {
1248             $changesfile = $multi;
1249         } else {
1250             $!==&ENOENT or die "$multi: $!";
1251             my $pat = "${package}_".(stripepoch $cversion)."_*.changes";
1252             my @cs = glob "../$pat";
1253             fail "failed to find unique changes file".
1254                 " (looked for $pat in .., or $multi);".
1255                 " perhaps you need to use dgit -C"
1256                 unless @cs==1;
1257             ($changesfile) = @cs;
1258         }
1259     }
1260
1261     responder_send_file('changes',$changesfile);
1262
1263     my $tfn = sub { ".git/dgit/tag$_[0]"; };
1264     my ($tagobjfn) =
1265         $we_are_responder
1266         ? responder_receive_files('signed-tag', $tfn->('.signed.tmp'))
1267         : push_mktag($head,$clogp,$tag,
1268                      $dsc,"../$dscfn",
1269                      $changesfile,$changesfile,
1270                                  $tfn);
1271
1272     my $tag_obj_hash = cmdoutput @git, qw(hash-object -w -t tag), $tagobjfn;
1273     runcmd_ordryrun @git, qw(verify-tag), $tag_obj_hash;
1274     runcmd_ordryrun_local @git, qw(update-ref), "refs/tags/$tag", $tag_obj_hash;
1275     runcmd_ordryrun @git, qw(tag -v --), $tag;
1276
1277     if (!check_for_git()) {
1278         create_remote_git_repo();
1279     }
1280     runcmd_ordryrun @git, qw(push),access_giturl(),"HEAD:".rrref();
1281     runcmd_ordryrun @git, qw(update-ref -m), 'dgit push', lrref(), 'HEAD';
1282
1283     if (!$we_are_responder) {
1284         if (act_local()) {
1285             rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
1286         } else {
1287             progress "[new .dsc left in $dscfn.tmp]";
1288         }
1289     }
1290
1291     if ($we_are_responder) {
1292         my $dryrunsuffix = act_local() ? "" : ".tmp";
1293         responder_receive_files('signed-dsc-changes',
1294                                 "../$dscfn$dryrunsuffix",
1295                                 "$changesfile$dryrunsuffix");
1296     } else {
1297         sign_changes $changesfile;
1298     }
1299
1300     runcmd_ordryrun @git, qw(push),access_giturl(),"refs/tags/$tag";
1301     my $host = access_cfg('upload-host','RETURN-UNDEF');
1302     my @hostarg = defined($host) ? ($host,) : ();
1303     runcmd_ordryrun @dput, @hostarg, $changesfile;
1304     printdone "pushed and uploaded $cversion";
1305
1306     responder_send_command("complete");
1307 }
1308
1309 sub cmd_clone {
1310     parseopts();
1311     my $dstdir;
1312     badusage "-p is not allowed with clone; specify as argument instead"
1313         if defined $package;
1314     if (@ARGV==1) {
1315         ($package) = @ARGV;
1316     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
1317         ($package,$isuite) = @ARGV;
1318     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
1319         ($package,$dstdir) = @ARGV;
1320     } elsif (@ARGV==3) {
1321         ($package,$isuite,$dstdir) = @ARGV;
1322     } else {
1323         badusage "incorrect arguments to dgit clone";
1324     }
1325     $dstdir ||= "$package";
1326     clone($dstdir);
1327 }
1328
1329 sub branchsuite () {
1330     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
1331     if ($branch =~ m#$lbranch_re#o) {
1332         return $1;
1333     } else {
1334         return undef;
1335     }
1336 }
1337
1338 sub fetchpullargs () {
1339     if (!defined $package) {
1340         my $sourcep = parsecontrol('debian/control','debian/control');
1341         $package = getfield $sourcep, 'Source';
1342     }
1343     if (@ARGV==0) {
1344 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
1345         if (!$isuite) {
1346             my $clogp = parsechangelog();
1347             $isuite = getfield $clogp, 'Distribution';
1348         }
1349         canonicalise_suite();
1350         progress "fetching from suite $csuite";
1351     } elsif (@ARGV==1) {
1352         ($isuite) = @ARGV;
1353         canonicalise_suite();
1354     } else {
1355         badusage "incorrect arguments to dgit fetch or dgit pull";
1356     }
1357 }
1358
1359 sub cmd_fetch {
1360     parseopts();
1361     fetchpullargs();
1362     fetch();
1363 }
1364
1365 sub cmd_pull {
1366     parseopts();
1367     fetchpullargs();
1368     pull();
1369 }
1370
1371 sub cmd_push {
1372     parseopts();
1373     badusage "-p is not allowed with dgit push" if defined $package;
1374     check_not_dirty();
1375     my $clogp = parsechangelog();
1376     $package = getfield $clogp, 'Source';
1377     my $specsuite;
1378     if (@ARGV==0) {
1379     } elsif (@ARGV==1) {
1380         ($specsuite) = (@ARGV);
1381     } else {
1382         badusage "incorrect arguments to dgit push";
1383     }
1384     $isuite = getfield $clogp, 'Distribution';
1385     if ($new_package) {
1386         local ($package) = $existing_package; # this is a hack
1387         canonicalise_suite();
1388     }
1389     if (defined $specsuite && $specsuite ne $isuite) {
1390         canonicalise_suite();
1391         $csuite eq $specsuite or
1392             fail "dgit push: changelog specifies $isuite ($csuite)".
1393                 " but command line specifies $specsuite";
1394     }
1395     if (check_for_git()) {
1396         git_fetch_us();
1397     }
1398     if (fetch_from_archive()) {
1399         is_fast_fwd(lrref(), 'HEAD') or
1400             fail "dgit push: HEAD is not a descendant".
1401                 " of the archive's version.\n".
1402                 "$us: To overwrite it, use git-merge -s ours ".lrref().".";
1403     } else {
1404         $new_package or
1405             fail "package appears to be new in this suite;".
1406                 " if this is intentional, use --new";
1407     }
1408     dopush();
1409 }
1410
1411 #---------- remote commands' implementation ----------
1412
1413 sub cmd_remote_push_responder {
1414     my ($nrargs) = shift @ARGV;
1415     my (@rargs) = @ARGV[0..$nrargs-1];
1416     @ARGV = @ARGV[$nrargs..$#ARGV];
1417     die unless @rargs;
1418     my ($dir) = @rargs;
1419     changedir $dir;
1420     $we_are_responder = 1;
1421     $debugprefix = ' ';
1422     autoflush STDOUT 1;
1423     responder_send_command("dgit-remote-push-ready");
1424     &cmd_push;
1425 }
1426
1427 our $i_tmp;
1428
1429 sub i_cleanup {
1430     local ($@);
1431     return unless defined $i_tmp;
1432     changedir "/";
1433     eval { rmtree $i_tmp; };
1434 }
1435
1436 sub i_method {
1437     my ($base,$selector,@args) = @_;
1438     $selector =~ s/\-/_/g;
1439     { no strict qw(refs); &{"${base}_${selector}"}(@args); }
1440 }
1441
1442 sub cmd_rpush {
1443     my $host = nextarg;
1444     my $dir;
1445     if ($host =~ m/^((?:[^][]|\[[^][]*\])*)\:/) {
1446         $host = $1;
1447         $dir = $'; #';
1448     } else {
1449         $dir = nextarg;
1450     }
1451     $dir =~ s{^-}{./-};
1452     my @rargs = ($dir);
1453     my @rdgit;
1454     push @rdgit, @dgit;
1455     push @rdgit, @ropts;
1456     push @rdgit, qw(remote-push-responder), (scalar @rargs), @rargs;
1457     push @rdgit, @ARGV;
1458     my @cmd = (@ssh, $host, shellquote @rdgit);
1459     printcmd \*DEBUG,$debugprefix."+",@cmd;
1460     eval {
1461         $i_tmp = tempdir();
1462         my $pid = open2(\*RO, \*RI, @cmd);
1463         changedir $i_tmp;
1464         initiator_expect { m/^dgit-remote-push-ready/ };
1465         for (;;) {
1466             my ($icmd,$iargs) = initiator_expect {
1467                 m/^(\S+)(?: (.*))?$/;
1468                 ($1,$2);
1469             };
1470             i_method "i_resp", $icmd, $iargs;
1471         }
1472     };
1473     i_cleanup();
1474     die $@;
1475 }
1476
1477 sub i_resp_progress ($) {
1478     my ($rhs) = @_;
1479     my $msg = protocol_read_bytes \*RO, $rhs;
1480     progress $msg;
1481 }
1482
1483 sub i_resp_complete {
1484     i_cleanup();
1485     exit 0;
1486 }
1487
1488 sub i_resp_file ($) {
1489     my ($keyword) = @_;
1490     my $localname = i_method "i_localname", $keyword;
1491     my $localpath = "$i_tmp/$localname";
1492     stat $localpath and badproto \*RO, "file $keyword ($localpath) twice";
1493     protocol_receive_file \*RO, $localpath;
1494 }
1495
1496 our %i_param;
1497
1498 sub i_param ($) {
1499     $_[0] =~ m/^(\S+) (.*)$/;
1500     $i_param{$1} = $2;
1501 }
1502
1503 our %i_wanted;
1504
1505 sub i_resp_want ($) {
1506     my ($keyword) = @_;
1507     die "$keyword ?" if $i_wanted{$keyword}++;
1508     my @localpaths = i_method "i_want", $keyword;
1509     printdebug "]]  $keyword @localpaths\n";
1510     foreach my $localpath (@localpaths) {
1511         protocol_send_file \*RI, $localpath;
1512     }
1513     print RI "end-files\n" or die $!;
1514 }
1515
1516 our ($i_clogp, $i_version, $i_tag, $i_dscfn);
1517
1518 sub i_localname_parsed_changelog { return "remote-changelog.822"; }
1519 sub i_localname_changes { return "remote.changes"; }
1520 sub i_localname_dsc {
1521     ($i_clogp, $i_version, $i_tag, $i_dscfn) =
1522         push_parse_changelog 'remote-changelog.822';
1523     die if $i_dscfn =~ m#/|^\W#;
1524     return $i_dscfn;
1525 }
1526
1527 sub i_want_signed_tag {
1528     defined $i_param{'head'} && defined $i_dscfn
1529         or badproto \*RO, "sequencing error";
1530     my $head = $i_param{'head'};
1531     die if $head =~ m/[^0-9a-f]/ || $head !~ m/^../;
1532
1533     push_parse_dsc $i_dscfn, 'remote dsc',
1534
1535     push_mktag $head, $i_clogp, $i_tag,
1536         $dsc, $i_dscfn,
1537         'remote.changes', 'remote changes',
1538         'tag.tag';
1539
1540     return 'tag.tag';
1541 }
1542
1543 sub i_want_signed_dsc_changes {
1544     rename "$i_dscfn.tmp","$i_dscfn" or die "$i_dscfn $!";
1545     sign_changes 'remote.changes';
1546     return ($i_dscfn, 'remote.changes');
1547 }
1548
1549 #---------- building etc. ----------
1550
1551 our $version;
1552 our $sourcechanges;
1553 our $dscfn;
1554
1555 our $fakeeditorenv = 'DGIT_FAKE_EDITOR_QUILT';
1556
1557 sub build_maybe_quilt_fixup () {
1558     if (!open F, "debian/source/format") {
1559         die $! unless $!==&ENOENT;
1560         return;
1561     }
1562     $_ = <F>;
1563     F->error and die $!;
1564     chomp;
1565     return unless madformat($_);
1566     # sigh
1567     my $clogp = parsechangelog();
1568     my $version = getfield $clogp, 'Version';
1569     my $author = getfield $clogp, 'Maintainer';
1570     my $headref = rev_parse('HEAD');
1571     my $time = time;
1572     my $ncommits = 3;
1573     my $patchname = "auto-$version-$headref-$time";
1574     my $msg = cmdoutput @git, qw(log), "-n$ncommits";
1575     mkpath '.git/dgit';
1576     my $descfn = ".git/dgit/quilt-description.tmp";
1577     open O, '>', $descfn or die "$descfn: $!";
1578     $msg =~ s/\n/\n /g;
1579     $msg =~ s/^\s+$/ ./mg;
1580     print O <<END or die $!;
1581 Description: Automatically generated patch ($clogp->{Version})
1582  Last (up to) $ncommits git changes, FYI:
1583  .
1584  $msg
1585 Author: $author
1586
1587 ---
1588
1589 END
1590     close O or die $!;
1591     {
1592         local $ENV{'EDITOR'} = cmdoutput qw(realpath --), $0;
1593         local $ENV{'VISUAL'} = $ENV{'EDITOR'};
1594         local $ENV{$fakeeditorenv} = cmdoutput qw(realpath --), $descfn;
1595         runcmd_ordryrun_local @dpkgsource, qw(--commit .), $patchname;
1596     }
1597
1598     if (!open P, '>>', ".pc/applied-patches") {
1599         $!==&ENOENT or die $!;
1600     } else {
1601         close P;
1602     }
1603
1604     commit_quilty_patch();
1605 }
1606
1607 sub quilt_fixup_editor () {
1608     my $descfn = $ENV{$fakeeditorenv};
1609     my $editing = $ARGV[$#ARGV];
1610     open I1, '<', $descfn or die "$descfn: $!";
1611     open I2, '<', $editing or die "$editing: $!";
1612     unlink $editing or die "$editing: $!";
1613     open O, '>', $editing or die "$editing: $!";
1614     while (<I1>) { print O or die $!; } I1->error and die $!;
1615     my $copying = 0;
1616     while (<I2>) {
1617         $copying ||= m/^\-\-\- /;
1618         next unless $copying;
1619         print O or die $!;
1620     }
1621     I2->error and die $!;
1622     close O or die $1;
1623     exit 0;
1624 }
1625
1626 sub build_prep () {
1627     badusage "-p is not allowed when building" if defined $package;
1628     check_not_dirty();
1629     my $clogp = parsechangelog();
1630     $isuite = getfield $clogp, 'Distribution';
1631     $package = getfield $clogp, 'Source';
1632     $version = getfield $clogp, 'Version';
1633     build_maybe_quilt_fixup();
1634 }
1635
1636 sub cmd_build {
1637     badusage "dgit build implies --clean=dpkg-source"
1638         if $cleanmode ne 'dpkg-source';
1639     build_prep();
1640     runcmd_ordryrun_local @dpkgbuildpackage, qw(-us -uc), changesopts(), @ARGV;
1641     printdone "build successful\n";
1642 }
1643
1644 sub cmd_git_build {
1645     badusage "dgit git-build implies --clean=dpkg-source"
1646         if $cleanmode ne 'dpkg-source';
1647     build_prep();
1648     my @cmd =
1649         (qw(git-buildpackage -us -uc --git-no-sign-tags),
1650          "--git-builder=@dpkgbuildpackage");
1651     unless (grep { m/^--git-debian-branch|^--git-ignore-branch/ } @ARGV) {
1652         canonicalise_suite();
1653         push @cmd, "--git-debian-branch=".lbranch();
1654     }
1655     push @cmd, changesopts();
1656     runcmd_ordryrun_local @cmd, @ARGV;
1657     printdone "build successful\n";
1658 }
1659
1660 sub build_source {
1661     build_prep();
1662     $sourcechanges = "${package}_".(stripepoch $version)."_source.changes";
1663     $dscfn = dscfn($version);
1664     if ($cleanmode eq 'dpkg-source') {
1665         runcmd_ordryrun_local (@dpkgbuildpackage, qw(-us -uc -S)),
1666             changesopts();
1667     } else {
1668         if ($cleanmode eq 'git') {
1669             runcmd_ordryrun_local @git, qw(clean -xdf);
1670         } elsif ($cleanmode eq 'none') {
1671         } else {
1672             die "$cleanmode ?";
1673         }
1674         my $pwd = cmdoutput qw(env - pwd);
1675         my $leafdir = basename $pwd;
1676         changedir "..";
1677         runcmd_ordryrun_local @dpkgsource, qw(-b --), $leafdir;
1678         changedir $pwd;
1679         runcmd_ordryrun_local qw(sh -ec),
1680             'exec >$1; shift; exec "$@"','x',
1681             "../$sourcechanges",
1682             @dpkggenchanges, qw(-S), changesopts();
1683     }
1684 }
1685
1686 sub cmd_build_source {
1687     badusage "build-source takes no additional arguments" if @ARGV;
1688     build_source();
1689     printdone "source built, results in $dscfn and $sourcechanges";
1690 }
1691
1692 sub cmd_sbuild {
1693     build_source();
1694     changedir "..";
1695     my $pat = "${package}_".(stripepoch $version)."_*.changes";
1696     if (act_local()) {
1697         stat $dscfn or fail "$dscfn (in parent directory): $!";
1698         stat $sourcechanges or fail "$sourcechanges (in parent directory): $!";
1699         foreach my $cf (glob $pat) {
1700             next if $cf eq $sourcechanges;
1701             unlink $cf or fail "remove $cf: $!";
1702         }
1703     }
1704     runcmd_ordryrun_local @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
1705     runcmd_ordryrun_local @mergechanges, glob $pat;
1706     my $multichanges = "${package}_".(stripepoch $version)."_multi.changes";
1707     if (act_local()) {
1708         stat $multichanges or fail "$multichanges: $!";
1709     }
1710     printdone "build successful, results in $multichanges\n" or die $!;
1711 }
1712
1713 sub cmd_quilt_fixup {
1714     badusage "incorrect arguments to dgit quilt-fixup" if @ARGV;
1715     my $clogp = parsechangelog();
1716     $version = getfield $clogp, 'Version';
1717     build_maybe_quilt_fixup();
1718 }
1719
1720 #---------- argument parsing and main program ----------
1721
1722 sub cmd_version {
1723     print "dgit version $our_version\n" or die $!;
1724     exit 0;
1725 }
1726
1727 sub parseopts () {
1728     my $om;
1729
1730     if (defined $ENV{'DGIT_SSH'}) {
1731         @ssh = string_to_ssh $ENV{'DGIT_SSH'};
1732     } elsif (defined $ENV{'GIT_SSH'}) {
1733         @ssh = ($ENV{'GIT_SSH'});
1734     }
1735
1736     while (@ARGV) {
1737         last unless $ARGV[0] =~ m/^-/;
1738         $_ = shift @ARGV;
1739         last if m/^--?$/;
1740         if (m/^--/) {
1741             if (m/^--dry-run$/) {
1742                 push @ropts, $_;
1743                 $dryrun_level=2;
1744             } elsif (m/^--damp-run$/) {
1745                 push @ropts, $_;
1746                 $dryrun_level=1;
1747             } elsif (m/^--no-sign$/) {
1748                 push @ropts, $_;
1749                 $sign=0;
1750             } elsif (m/^--help$/) {
1751                 cmd_help();
1752             } elsif (m/^--version$/) {
1753                 cmd_version();
1754             } elsif (m/^--new$/) {
1755                 push @ropts, $_;
1756                 $new_package=1;
1757             } elsif (m/^--(\w+)=(.*)/s &&
1758                      ($om = $opts_opt_map{$1}) &&
1759                      length $om->[0]) {
1760                 push @ropts, $_;
1761                 $om->[0] = $2;
1762             } elsif (m/^--(\w+):(.*)/s &&
1763                      !$opts_opt_cmdonly{$1} &&
1764                      ($om = $opts_opt_map{$1})) {
1765                 push @ropts, $_;
1766                 push @$om, $2;
1767             } elsif (m/^--existing-package=(.*)/s) {
1768                 push @ropts, $_;
1769                 $existing_package = $1;
1770             } elsif (m/^--distro=(.*)/s) {
1771                 push @ropts, $_;
1772                 $idistro = $1;
1773             } elsif (m/^--clean=(dpkg-source|git|none)$/s) {
1774                 push @ropts, $_;
1775                 $cleanmode = $1;
1776             } elsif (m/^--clean=(.*)$/s) {
1777                 badusage "unknown cleaning mode \`$1'";
1778             } elsif (m/^--ignore-dirty$/s) {
1779                 push @ropts, $_;
1780                 $ignoredirty = 1;
1781             } elsif (m/^--no-quilt-fixup$/s) {
1782                 push @ropts, $_;
1783                 $noquilt = 1;
1784             } else {
1785                 badusage "unknown long option \`$_'";
1786             }
1787         } else {
1788             while (m/^-./s) {
1789                 if (s/^-n/-/) {
1790                     push @ropts, $&;
1791                     $dryrun_level=2;
1792                 } elsif (s/^-L/-/) {
1793                     push @ropts, $&;
1794                     $dryrun_level=1;
1795                 } elsif (s/^-h/-/) {
1796                     cmd_help();
1797                 } elsif (s/^-D/-/) {
1798                     push @ropts, $&;
1799                     open DEBUG, ">&STDERR" or die $!;
1800                     autoflush DEBUG 1;
1801                     $debug++;
1802                 } elsif (s/^-N/-/) {
1803                     push @ropts, $&;
1804                     $new_package=1;
1805                 } elsif (m/^-[vm]/) {
1806                     push @ropts, $&;
1807                     push @changesopts, $_;
1808                     $_ = '';
1809                 } elsif (s/^-c(.*=.*)//s) {
1810                     push @ropts, $&;
1811                     push @git, '-c', $1;
1812                 } elsif (s/^-d(.*)//s) {
1813                     push @ropts, $&;
1814                     $idistro = $1;
1815                 } elsif (s/^-C(.*)//s) {
1816                     push @ropts, $&;
1817                     $changesfile = $1;
1818                 } elsif (s/^-k(.*)//s) {
1819                     $keyid=$1;
1820                 } elsif (s/^-wn//s) {
1821                     push @ropts, $&;
1822                     $cleanmode = 'none';
1823                 } elsif (s/^-wg//s) {
1824                     push @ropts, $&;
1825                     $cleanmode = 'git';
1826                 } elsif (s/^-wd//s) {
1827                     push @ropts, $&;
1828                     $cleanmode = 'dpkg-source';
1829                 } else {
1830                     badusage "unknown short option \`$_'";
1831                 }
1832             }
1833         }
1834     }
1835 }
1836
1837 if ($ENV{$fakeeditorenv}) {
1838     quilt_fixup_editor();
1839 }
1840
1841 delete $ENV{'DGET_UNPACK'};
1842
1843 parseopts();
1844 print STDERR "DRY RUN ONLY\n" if $dryrun_level > 1;
1845 print STDERR "DAMP RUN - WILL MAKE LOCAL (UNSIGNED) CHANGES\n"
1846     if $dryrun_level == 1;
1847 if (!@ARGV) {
1848     print STDERR $helpmsg or die $!;
1849     exit 8;
1850 }
1851 my $cmd = shift @ARGV;
1852 $cmd =~ y/-/_/;
1853 { no strict qw(refs); &{"cmd_$cmd"}(); }