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::Basename;
  28 use Dpkg::Version;
  29 use POSIX;
  30
  31 our $isuite = 'unstable';
  32 our $idistro;
  33 our $package;
  34
  35 our $sign = 1;
  36 our $dryrun = 0;
  37 our $changesfile;
  38 our $new_package = 0;
  39 our $existing_package = 'dpkg';
  40 our $build_use_dpkgbuildpackage = 0;
  41
  42 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
  43
  44 our (@git) = qw(git);
  45 our (@dget) = qw(dget);
  46 our (@dput) = qw(dput);
  47 our (@debsign) = qw(debsign);
  48 our (@sbuild) = qw(sbuild -A);
  49 our (@dpkgbuildpackage) = qw(dpkg-buildpackage -i\.git/ -I.git);
  50 our (@dpkgsource) = qw(dpkg-source -i\.git/ -I.git);
  51 our (@mergechanges) = qw(mergechanges -f);
  52
  53
  54 our %opts_opt_map = ('dget' => \@dget,
  55                      'dput' => \@dput,
  56                      'debsign' => \@debsign,
  57                      'sbuild' => \@sbuild,
  58                      'dpkg-source' => \@dpkgsource,
  59                      'dpkg-buildpackage' => \@dpkgbuildpackage,
  60                      'mergechanges' => \@mergechanges);
  61
  62 our $keyid;
  63
  64 our $debug = 0;
  65 open DEBUG, ">/dev/null" or die $!;
  66
  67 our $remotename = 'dgit';
  68 our $ourdscfield = 'Vcs-Dgit-Master';
  69 our $branchprefix = 'dgit';
  70 our $csuite;
  71
  72 sub lbranch () { return "$branchprefix/$csuite"; }
  73 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
  74 sub lref () { return "refs/heads/".lbranch(); }
  75 sub lrref () { return "refs/remotes/$remotename/$branchprefix/$csuite"; }
  76 sub rrref () { return "refs/$branchprefix/$csuite"; }
  77 sub debiantag ($) {
  78     my ($v) = @_;
  79     $v =~ y/~:/_%/;
  80     return "debian/$v";
  81 }
  82
  83 sub dscfn ($) { return "${package}_$_[0].dsc"; }
  84
  85 our $us = 'dgit';
  86
  87 sub fail { die "$us: @_\n"; }
  88
  89 sub badcfg { print STDERR "$us: invalid configuration: @_\n"; exit 12; }
  90
  91 sub no_such_package () {
  92     print STDERR "$us: package $package does not exist in suite $isuite\n";
  93     exit 4;
  94 }
  95
  96 sub fetchspec () {
  97     local $csuite = '*';
  98     return  "+".rrref().":".lrref();
  99 }
 100
 101 our $ua;
 102
 103 sub url_get {
 104     if (!$ua) {
 105         $ua = LWP::UserAgent->new();
 106         $ua->env_proxy;
 107     }
 108     my $what = $_[$#_];
 109     print "downloading $what...\n";
 110     my $r = $ua->get(@_) or die $!;
 111     return undef if $r->code == 404;
 112     $r->is_success or fail "failed to fetch $what: ".$r->status_line;
 113     return $r->decoded_content();
 114 }
 115
 116 our ($dscdata,$dscurl,$dsc);
 117
 118 sub printcmd {
 119     my $fh = shift @_;
 120     my $intro = shift @_;
 121     print $fh $intro or die $!;
 122     local $_;
 123     foreach my $a (@_) {
 124         $_ = $a;
 125         if (s{['\\]}{\\$&}g || m{\s} || m{[^-_./0-9a-z]}i) {
 126             print $fh " '$_'" or die $!;
 127         } else {
 128             print $fh " $_" or die $!;
 129         }
 130     }
 131     print $fh "\n" or die $!;
 132 }
 133
 134 sub failedcmd {
 135     { local ($!); printcmd \*STDERR, "$_[0]: failed command:", @_ or die $!; };
 136     if ($!) {
 137         fail "failed to fork/exec: $!";
 138     } elsif (!($? & 0xff)) {
 139         fail "subprocess failed with error exit status ".($?>>8);
 140     } elsif ($?) {
 141         fail "subprocess crashed (wait status $?)";
 142     } else {
 143         fail "subprocess produced invalid output";
 144     }
 145 }
 146
 147 sub runcmd {
 148     printcmd(\*DEBUG,"+",@_) if $debug>0;
 149     $!=0; $?=0;
 150     failedcmd @_ if system @_;
 151 }
 152
 153 sub printdone {
 154     if (!$dryrun) {
 155         print "dgit ok: @_\n";
 156     } else {
 157         print "would be ok: @_ (but dry run only)\n";
 158     }
 159 }
 160
 161 sub cmdoutput_errok {
 162     die Dumper(\@_)." ?" if grep { !defined } @_;
 163     printcmd(\*DEBUG,"|",@_) if $debug>0;
 164     open P, "-|", @_ or die $!;
 165     my $d;
 166     $!=0; $?=0;
 167     { local $/ = undef; $d = <P>; }
 168     die $! if P->error;
 169     if (!close P) { print DEBUG "=>!$?\n" if $debug>0; return undef; }
 170     chomp $d;
 171     $d =~ m/^.*/;
 172     print DEBUG "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #';
 173     return $d;
 174 }
 175
 176 sub cmdoutput {
 177     my $d = cmdoutput_errok @_;
 178     defined $d or failedcmd @_;
 179     return $d;
 180 }
 181
 182 sub dryrun_report {
 183     printcmd(\*STDOUT,"#",@_);
 184 }
 185
 186 sub runcmd_ordryrun {
 187     if (!$dryrun) {
 188         runcmd @_;
 189     } else {
 190         dryrun_report @_;
 191     }
 192 }
 193
 194 our $helpmsg = <<END;
 195 main usages:
 196   dgit [dgit-opts] clone [dgit-opts] package [suite] [./dir|/dir]
 197   dgit [dgit-opts] fetch|pull [dgit-opts] [suite]
 198   dgit [dgit-opts] build [git-buildpackage-opts|dpkg-buildpackage-opts]
 199   dgit [dgit-opts] push [dgit-opts] [suite]
 200 important dgit options:
 201   -k<keyid>           sign tag and package with <keyid> instead of default
 202   --dry-run -n        do not change anything, but go through the motions
 203   --new -N            allow introducing a new package
 204   --debug -D          increase debug level
 205   -c<name>=<value>    set git config option (used directly by dgit too)
 206 END
 207
 208 our $later_warning_msg = <<END;
 209 Perhaps the upload is stuck in incoming.  Using the version from git.
 210 END
 211
 212 sub badusage {
 213     print STDERR "$us: @_\n", $helpmsg or die $!;
 214     exit 8;
 215 }
 216
 217 sub helponly () {
 218     print $helpmsg or die $!;
 219     exit 0;
 220 }
 221
 222 our %defcfg = ('dgit.default.distro' => 'debian',
 223                'dgit.default.username' => '',
 224                'dgit.default.archive-query-default-component' => 'main',
 225                'dgit.default.ssh' => 'ssh',
 226                'dgit-distro.debian.git-host' => 'git.debian.org',
 227                'dgit-distro.debian.git-proto' => 'git+ssh://',
 228                'dgit-distro.debian.git-path' => '/git/dgit-repos',
 229                'dgit-distro.debian.git-check' => 'ssh-cmd',
 230                'dgit-distro.debian.git-create' => 'ssh-cmd',
 231                'dgit-distro.debian.sshdakls-host' => 'coccia.debian.org',
 232                'dgit-distro.debian.sshdakls-dir' =>
 233                    '/srv/ftp-master.debian.org/ftp/dists',
 234                'dgit-distro.debian.mirror' => 'http://http.debian.net/debian/');
 235
 236 sub cfg {
 237     foreach my $c (@_) {
 238         return undef if $c =~ /RETURN-UNDEF/;
 239         my @cmd = (@git, qw(config --), $c);
 240         my $v;
 241         {
 242             local ($debug) = $debug-1;
 243             $v = cmdoutput_errok @cmd;
 244         };
 245         if ($?==0) {
 246             return $v;
 247         } elsif ($?!=256) {
 248             failedcmd @cmd;
 249         }
 250         my $dv = $defcfg{$c};
 251         return $dv if defined $dv;
 252     }
 253     badcfg "need value for one of: @_";
 254 }
 255
 256 sub access_distro () {
 257     return cfg("dgit-suite.$isuite.distro",
 258                "dgit.default.distro");
 259 }
 260
 261 sub access_cfg (@) {
 262     my (@keys) = @_;
 263     my $distro = $idistro || access_distro();
 264     my $value = cfg(map { ("dgit-distro.$distro.$_",
 265                            "dgit.default.$_") } @keys);
 266     return $value;
 267 }
 268
 269 sub access_someuserhost ($) {
 270     my ($some) = @_;
 271     my $user = access_cfg("$some-user",'username');
 272     my $host = access_cfg("$some-host");
 273     return length($user) ? "$user\@$host" : $host;
 274 }
 275
 276 sub access_gituserhost () {
 277     return access_someuserhost('git');
 278 }
 279
 280 sub access_giturl () {
 281     my $url = access_cfg('git-url','RETURN-UNDEF');
 282     if (!defined $url) {
 283         $url =
 284             access_cfg('git-proto').
 285             access_gituserhost().
 286             access_cfg('git-path');
 287     }
 288     return "$url/$package.git";
 289 }
 290
 291 sub parsecontrolfh ($$@) {
 292     my ($fh, $desc, @opts) = @_;
 293     my %opts = ('name' => $desc, @opts);
 294     my $c = Dpkg::Control::Hash->new(%opts);
 295     $c->parse($fh) or die "parsing of $desc failed";
 296     return $c;
 297 }
 298
 299 sub parsecontrol {
 300     my ($file, $desc) = @_;
 301     my $fh = new IO::Handle;
 302     open $fh, '<', $file or die "$file: $!";
 303     my $c = parsecontrolfh($fh,$desc);
 304     $fh->error and die $!;
 305     close $fh;
 306     return $c;
 307 }
 308
 309 sub getfield ($$) {
 310     my ($dctrl,$field) = @_;
 311     my $v = $dctrl->{$field};
 312     return $v if defined $v;
 313     fail "missing field $field in ".$v->get_option('name');
 314 }
 315
 316 sub parsechangelog {
 317     my $c = Dpkg::Control::Hash->new();
 318     my $p = new IO::Handle;
 319     my @cmd = (qw(dpkg-parsechangelog));
 320     open $p, '-|', @cmd or die $!;
 321     $c->parse($p);
 322     $?=0; $!=0; close $p or failedcmd @cmd;
 323     return $c;
 324 }
 325
 326 our %rmad;
 327
 328 sub archive_query ($) {
 329     my ($method) = @_;
 330     my $query = access_cfg('archive-query','RETURN-UNDEF');
 331     if (!defined $query) {
 332         my $distro = access_distro();
 333         if ($distro eq 'debian') {
 334             $query = "sshdakls:".
 335                 access_someuserhost('sshdakls').':'.
 336                 access_cfg('sshdakls-dir');
 337         } else {
 338             $query = "madison:$distro";
 339         }
 340     }
 341     $query =~ s/^(\w+):// or badcfg "invalid archive-query method \`$query'";
 342     my $proto = $1;
 343     my $data = $'; #';
 344     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
 345 }
 346
 347 sub archive_query_madison ($$) {
 348     my ($proto,$data) = @_;
 349     die unless $proto eq 'madison';
 350     $rmad{$package} ||= cmdoutput
 351         qw(rmadison -asource),"-s$isuite","-u$data",$package;
 352     my $rmad = $rmad{$package};
 353     return madison_parse($rmad);
 354 }
 355
 356 sub archive_query_sshdakls ($$) {
 357     my ($proto,$data) = @_;
 358     $data =~ s/:.*// or badcfg "invalid sshdakls method string \`$data'";
 359     my $dakls = cmdoutput
 360         access_cfg('ssh'), $data, qw(dak ls -asource),"-s$isuite",$package;
 361     return madison_parse($dakls);
 362 }
 363
 364 sub canonicalise_suite_sshdakls ($$) {
 365     my ($proto,$data) = @_;
 366     $data =~ m/:/ or badcfg "invalid sshdakls method string \`$data'";
 367     my @cmd =
 368         (access_cfg('ssh'), $`,
 369          "set -e; cd $';".
 370          " if test -h $isuite; then readlink $isuite; exit 0; fi;".
 371          " if test -d $isuite; then echo $isuite; exit 0; fi;".
 372          " exit 1");
 373     my $dakls = cmdoutput @cmd;
 374     failedcmd @cmd unless $dakls =~ m/^\w/;
 375     return $dakls;
 376 }
 377
 378 sub madison_parse ($) {
 379     my ($rmad) = @_;
 380     my @out;
 381     foreach my $l (split /\n/, $rmad) {
 382         $l =~ m{^ \s*( [^ \t|]+ )\s* \|
 383                   \s*( [^ \t|]+ )\s* \|
 384                   \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
 385                   \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
 386         $1 eq $package or die "$rmad $package ?";
 387         my $vsn = $2;
 388         my $newsuite = $3;
 389         my $component;
 390         if (defined $4) {
 391             $component = $4;
 392         } else {
 393             $component = access_cfg('archive-query-default-component');
 394         }
 395         $5 eq 'source' or die "$rmad ?";
 396         my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
 397         my $subpath = "/pool/$component/$prefix/$package/${package}_$vsn.dsc";
 398         push @out, [$vsn,$subpath,$newsuite];
 399     }
 400     return sort { -version_compare_string($a->[0],$b->[0]); } @out;
 401 }
 402
 403 sub canonicalise_suite_madison ($$) {
 404     my @r = archive_query_madison($_[0],$_[1]);
 405     @r or fail
 406         "unable to canonicalise suite using package $package".
 407         " which does not appear to exist in suite $isuite;".
 408         " --existing-package may help";
 409     return $r[0][2];
 410 }
 411
 412 sub canonicalise_suite () {
 413     $csuite = archive_query('canonicalise_suite');
 414     if ($isuite ne $csuite) {
 415         # madison canonicalises for us
 416         print "canonical suite name for $isuite is $csuite\n";
 417     }
 418 }
 419
 420 sub get_archive_dsc () {
 421     canonicalise_suite();
 422     my @vsns = archive_query('archive_query');
 423     foreach my $vinfo (@vsns) {
 424         my ($vsn,$subpath) = @$vinfo;
 425         $dscurl = access_cfg('mirror').$subpath;
 426         $dscdata = url_get($dscurl);
 427         next unless defined $dscdata;
 428         $dscurl = access_cfg('mirror').$subpath;
 429         $dscdata = url_get($dscurl);
 430         my $dscfh = new IO::File \$dscdata, '<' or die $!;
 431         print DEBUG Dumper($dscdata) if $debug>1;
 432         $dsc = parsecontrolfh($dscfh,$dscurl, allow_pgp=>1);
 433         print DEBUG Dumper($dsc) if $debug>1;
 434         my $fmt = getfield $dsc, 'Format';
 435         fail "unsupported source format $fmt, sorry" unless $format_ok{$fmt};
 436         return $dsc;
 437     }
 438     return undef;
 439 }
 440
 441 sub check_for_git () {
 442     # returns 0 or 1
 443     my $how = access_cfg('git-check');
 444     if ($how eq 'ssh-cmd') {
 445         my @cmd =
 446             (access_cfg('ssh'),access_gituserhost(),
 447              " set -e; cd ".access_cfg('git-path').";".
 448              " if test -d $package.git; then echo 1; else echo 0; fi");
 449         my $r= cmdoutput @cmd;
 450         failedcmd @cmd unless $r =~ m/^[01]$/;
 451         return $r+0;
 452     } else {
 453         badcfg "unknown git-check \`$how'";
 454     }
 455 }
 456
 457 sub create_remote_git_repo () {
 458     my $how = access_cfg('git-create');
 459     if ($how eq 'ssh-cmd') {
 460         runcmd_ordryrun
 461             (access_cfg('ssh'),access_gituserhost(),
 462              "set -e; cd ".access_cfg('git-path').";".
 463              " cp -a _template $package.git");
 464     } else {
 465         badcfg "unknown git-create \`$how'";
 466     }
 467 }
 468
 469 our ($dsc_hash,$upload_hash);
 470
 471 our $ud = '.git/dgit/unpack';
 472
 473 sub prep_ud () {
 474     rmtree($ud);
 475     mkpath '.git/dgit';
 476     mkdir $ud or die $!;
 477 }
 478
 479 sub mktree_in_ud_from_only_subdir () {
 480     # changes into the subdir
 481     my (@dirs) = <*/.>;
 482     die unless @dirs==1;
 483     $dirs[0] =~ m#^([^/]+)/\.$# or die;
 484     my $dir = $1;
 485     chdir $dir or die "$dir $!";
 486     die if stat '.git';
 487     die $! unless $!==&ENOENT;
 488     runcmd qw(git init -q);
 489     rmtree('.git/objects');
 490     symlink '../../../../objects','.git/objects' or die $!;
 491     runcmd @git, qw(add -Af);
 492     my $tree = cmdoutput @git, qw(write-tree);
 493     $tree =~ m/^\w+$/ or die "$tree ?";
 494     return ($tree,$dir);
 495 }
 496
 497 sub dsc_files () {
 498     my $field = $dsc->{'Checksums-Sha256'} || $dsc->{Files};
 499     defined $field or
 500         fail "missing both Checksums-Sha256 and Files in ".
 501         $dsc->get_option('name');
 502     map {
 503         m/^\w+ \d+ (\S+)$/ or
 504             fail "could not parse .dsc Files/Checksums line \`$_'";
 505         $1;
 506     } grep m/\S/, split /\n/, $field;
 507 }
 508
 509 sub is_orig_file ($) {
 510     local ($_) = @_;
 511     m/\.orig(?:-\w+)?\.tar\.\w+$/;
 512 }
 513
 514 sub make_commit ($) {
 515     my ($file) = @_;
 516     return cmdoutput @git, qw(hash-object -w -t commit), $file;
 517 }
 518
 519 sub generate_commit_from_dsc () {
 520     prep_ud();
 521     chdir $ud or die $!;
 522     my @files;
 523     foreach my $f (dsc_files()) {
 524         die "$f ?" if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
 525         push @files, $f;
 526         link "../../../$f", $f
 527             or $!==&ENOENT
 528             or die "$f $!";
 529     }
 530     runcmd @dget, qw(--), $dscurl;
 531     foreach my $f (grep { is_orig_file($_) } @files) {
 532         link $f, "../../../../$f"
 533             or $!==&EEXIST
 534             or die "$f $!";
 535     }
 536     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
 537     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
 538     my $clogp = parsecontrol('../changelog.tmp',"commit's changelog");
 539     my $date = cmdoutput qw(date), '+%s %z', qw(-d), getfield($clogp,'Date');
 540     my $author = getfield $clogp, 'Maintainer';
 541     $author =~ s#,.*##ms;
 542     my $authline = "$author $date";
 543     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or
 544         fail "unexpected commit author line format \`$authline'".
 545             " (was generated from changelog Maintainer field)";
 546     my $changes = getfield $clogp, 'Changes';
 547     open C, ">../commit.tmp" or die $!;
 548     print C <<END or die $!;
 549 tree $tree
 550 author $authline
 551 committer $authline
 552
 553 $changes
 554
 555 # imported from the archive
 556 END
 557     close C or die $!;
 558     my $outputhash = make_commit qw(../commit.tmp);
 559     my $cversion = getfield $clogp, 'Version';
 560     print "synthesised git commit from .dsc $cversion\n";
 561     if ($upload_hash) {
 562         runcmd @git, qw(reset --hard), $upload_hash;
 563         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
 564         my $oldclogp = parsecontrol('../changelogold.tmp','previous changelog');
 565         my $oversion = getfield $oldclogp, 'Version';
 566         my $vcmp =
 567             version_compare_string($oversion, $cversion);
 568         if ($vcmp < 0) {
 569             # git upload/ is earlier vsn than archive, use archive
 570             open C, ">../commit2.tmp" or die $!;
 571             print C <<END or die $!;
 572 tree $tree
 573 parent $upload_hash
 574 parent $outputhash
 575 author $authline
 576 committer $authline
 577
 578 Record $package ($cversion) in archive suite $csuite
 579 END
 580             $outputhash = make_commit qw(../commit2.tmp);
 581         } elsif ($vcmp > 0) {
 582             print STDERR <<END or die $!;
 583
 584 Version actually in archive:    $cversion (older)
 585 Last allegedly pushed/uploaded: $oversion (newer or same)
 586 $later_warning_msg
 587 END
 588             $outputhash = $upload_hash;
 589         } elsif ($outputhash ne $upload_hash) {
 590             fail "version in archive ($cversion)".
 591                 " is same as version in git".
 592                 " to-be-uploaded (upload/) branch ($oversion)".
 593                 " but archive version hash no commit hash?!";
 594         }
 595     }
 596     chdir '../../../..' or die $!;
 597     runcmd @git, qw(update-ref -m),"dgit fetch import $cversion",
 598             'DGIT_ARCHIVE', $outputhash;
 599     cmdoutput @git, qw(log -n2), $outputhash;
 600     # ... gives git a chance to complain if our commit is malformed
 601     rmtree($ud);
 602     return $outputhash;
 603 }
 604
 605 sub ensure_we_have_orig () {
 606     foreach my $f (dsc_files()) {
 607         next unless is_orig_file($f);
 608         if (stat "../$f") {
 609             die "$f ?" unless -f _;
 610         } else {
 611             die "$f $!" unless $!==&ENOENT;
 612         }
 613         my $origurl = $dscurl;
 614         $origurl =~ s{/[^/]+$}{};
 615         $origurl .= "/$f";
 616         die "$f ?" unless $f =~ m/^${package}_/;
 617         die "$f ?" if $f =~ m#/#;
 618         runcmd_ordryrun qw(sh -ec),'cd ..; exec "$@"','x',
 619             @dget,'--',$origurl;
 620     }
 621 }
 622
 623 sub rev_parse ($) {
 624     return cmdoutput @git, qw(rev-parse), "$_[0]~0";
 625 }
 626
 627 sub is_fast_fwd ($$) {
 628     my ($ancestor,$child) = @_;
 629     my $mb = cmdoutput @git, qw(merge-base), $ancestor, $child;
 630     return rev_parse($mb) eq rev_parse($ancestor);
 631 }
 632
 633 sub git_fetch_us () {
 634     badusage "cannot dry run with fetch" if $dryrun;
 635     runcmd @git, qw(fetch),access_giturl(),fetchspec();
 636 }
 637
 638 sub fetch_from_archive () {
 639     # ensures that lrref() is what is actually in the archive,
 640     #  one way or another
 641     get_archive_dsc() or return 0;
 642     $dsc_hash = $dsc->{$ourdscfield};
 643     if (defined $dsc_hash) {
 644         $dsc_hash =~ m/\w+/ or fail "invalid hash in .dsc \`$dsc_hash'";
 645         $dsc_hash = $&;
 646         print "last upload to archive specified git hash\n";
 647     } else {
 648         print "last upload to archive has NO git hash\n";
 649     }
 650
 651     my $lrref_fn = ".git/".lrref();
 652     if (open H, $lrref_fn) {
 653         $upload_hash = <H>;
 654         chomp $upload_hash;
 655         die "$lrref_fn $upload_hash ?" unless $upload_hash =~ m/^\w+$/;
 656     } elsif ($! == &ENOENT) {
 657         $upload_hash = '';
 658     } else {
 659         die "$lrref_fn $!";
 660     }
 661     print DEBUG "previous reference hash=$upload_hash\n";
 662     my $hash;
 663     if (defined $dsc_hash) {
 664         fail "missing git history even though dsc has hash -".
 665             " could not find commit $dsc_hash".
 666             " (should be in ".access_giturl()."#".rrref().")"
 667             unless $upload_hash;
 668         $hash = $dsc_hash;
 669         ensure_we_have_orig();
 670         if ($dsc_hash eq $upload_hash) {
 671         } elsif (is_fast_fwd($dsc_hash,$upload_hash)) {
 672             print STDERR <<END or die $!;
 673
 674 Git commit in archive is behind the last version allegedly pushed/uploaded.
 675 Commit referred to by archive:  $dsc_hash
 676 Last allegedly pushed/uploaded: $upload_hash
 677 $later_warning_msg
 678 END
 679             $hash = $upload_hash;
 680         } else {
 681             fail "archive's .dsc refers to ".$dsc_hash.
 682                 " but this is an ancestor of ".$upload_hash;
 683         }
 684     } else {
 685         $hash = generate_commit_from_dsc();
 686     }
 687     print DEBUG "current hash=$hash\n";
 688     if ($upload_hash) {
 689         fail "not fast forward on last upload branch!".
 690             " (archive's version left in DGIT_ARCHIVE)"
 691             unless is_fast_fwd($upload_hash, $hash);
 692     }
 693     if ($upload_hash ne $hash) {
 694         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
 695         if (!$dryrun) {
 696             cmdoutput @upd_cmd;
 697         } else {
 698             dryrun_report @upd_cmd;
 699         }
 700     }
 701     return 1;
 702 }
 703
 704 sub clone ($) {
 705     my ($dstdir) = @_;
 706     canonicalise_suite();
 707     badusage "dry run makes no sense with clone" if $dryrun;
 708     mkdir $dstdir or die "$dstdir $!";
 709     chdir "$dstdir" or die "$dstdir $!";
 710     runcmd @git, qw(init -q);
 711     runcmd @git, qw(config), "remote.$remotename.fetch", fetchspec();
 712     open H, "> .git/HEAD" or die $!;
 713     print H "ref: ".lref()."\n" or die $!;
 714     close H or die $!;
 715     runcmd @git, qw(remote add), 'origin', access_giturl();
 716     if (check_for_git()) {
 717         print "fetching existing git history\n";
 718         git_fetch_us();
 719         runcmd @git, qw(fetch origin);
 720     } else {
 721         print "starting new git history\n";
 722     }
 723     fetch_from_archive() or no_such_package;
 724     runcmd @git, qw(reset --hard), lrref();
 725     printdone "ready for work in $dstdir";
 726 }
 727
 728 sub fetch () {
 729     if (check_for_git()) {
 730         git_fetch_us();
 731     }
 732     fetch_from_archive() or no_such_package();
 733     printdone "fetched into ".lrref();
 734 }
 735
 736 sub pull () {
 737     fetch();
 738     runcmd_ordryrun @git, qw(merge -m),"Merge from $csuite [dgit]",
 739         lrref();
 740     printdone "fetched to ".lrref()." and merged into HEAD";
 741 }
 742
 743 sub check_not_dirty () {
 744     my @cmd = (@git, qw(diff --quiet HEAD));
 745     printcmd(\*DEBUG,"+",@cmd) if $debug>0;
 746     $!=0; $?=0; system @cmd;
 747     return if !$! && !$?;
 748     if (!$! && $?==256) {
 749         fail "working tree is dirty (does not match HEAD)";
 750     } else {
 751         failedcmd @cmd;
 752     }
 753 }
 754
 755 sub commit_quilty_patch ($) {
 756     my ($vsn) = @_;
 757     my $output = cmdoutput @git, qw(status --porcelain);
 758     my %fixups = map {$_=>1}
 759         (".pc/debian-changes-$vsn/","debian/patches/debian-changes-$vsn");
 760     my @files;
 761     foreach my $l (split /\n/, $output) {
 762         next unless $l =~ s/^\?\? //;
 763         next unless $fixups{$l};
 764         push @files, $l;
 765     }
 766     print DEBUG "checking for quilty\n", Dumper(\@files);
 767     if (@files == 2) {
 768         my $m = "Commit Debian 3.0 (quilt) metadata";
 769         print "$m\n";
 770         runcmd_ordryrun @git, qw(add), @files;
 771         runcmd_ordryrun @git, qw(commit -m), $m;
 772     }
 773 }
 774
 775 sub dopush () {
 776     print DEBUG "actually entering push\n";
 777     my $clogp = parsechangelog();
 778     $package = getfield $clogp, 'Source';
 779     my $cversion = getfield $clogp, 'Version';
 780     my $dscfn = dscfn($cversion);
 781     stat "../$dscfn" or
 782         fail "looked for .dsc $dscfn, but $!;".
 783             " maybe you forgot to build";
 784     $dsc = parsecontrol("../$dscfn","$dscfn");
 785     my $dscpackage = getfield $dsc, 'Source';
 786     my $format = getfield $dsc, 'Format';
 787     my $dversion = getfield $dsc, 'Version';
 788     ($dscpackage eq $package && $dversion eq $cversion) or
 789         fail "$dsc is for $dscpackage $dversion".
 790             " but debian/changelog is for $package $cversion";
 791     print DEBUG "format $format\n";
 792     if ($format eq '3.0 (quilt)') {
 793         print "Format \`$format', urgh\n";
 794         commit_quilty_patch($dversion);
 795     }
 796     check_not_dirty();
 797     prep_ud();
 798     chdir $ud or die $!;
 799     print "checking that $dscfn corresponds to HEAD\n";
 800     runcmd qw(dpkg-source -x --), "../../../../$dscfn";
 801     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
 802     chdir '../../../..' or die $!;
 803     printcmd \*DEBUG,"+",@_;
 804     my @diffcmd = (@git, qw(diff --exit-code), $tree);
 805     $!=0; $?=0;
 806     if (system @diffcmd) {
 807         if ($! && $?==256) {
 808             fail "$dscfn specifies a different tree to your HEAD commit;".
 809                 " perhaps you forgot to build";
 810         } else {
 811             failedcmd @diffcmd;
 812         }
 813     }
 814 #fetch from alioth
 815 #do fast forward check and maybe fake merge
 816 #    if (!is_fast_fwd(mainbranch
 817 #    runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
 818 #        map { lref($_).":".rref($_) }
 819 #        (uploadbranch());
 820     $dsc->{$ourdscfield} = rev_parse('HEAD');
 821     $dsc->save("../$dscfn.tmp") or die $!;
 822     if (!$changesfile) {
 823         my $multi = "../${package}_${cversion}_multi.changes";
 824         if (stat "$multi") {
 825             $changesfile = $multi;
 826         } else {
 827             $!==&ENOENT or die "$multi: $!";
 828             my $pat = "${package}_${cversion}_*.changes";
 829             my @cs = glob "../$pat";
 830             fail "failed to find unique changes file".
 831                 " (looked for $pat in .., or $multi);".
 832                 " perhaps you need to use dgit -C"
 833                 unless @cs==1;
 834             ($changesfile) = @cs;
 835         }
 836     }
 837     my $tag = debiantag($dversion);
 838     if (!check_for_git()) {
 839         create_remote_git_repo();
 840     }
 841     runcmd_ordryrun @git, qw(push),access_giturl(),"HEAD:".rrref();
 842     if (!$dryrun) {
 843         rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
 844     } else {
 845         print "[new .dsc left in $dscfn.tmp]\n";
 846     }
 847     if ($sign) {
 848         if (!defined $keyid) {
 849             $keyid = access_cfg('keyid','RETURN-UNDEF');
 850         }
 851         my @tag_cmd = (@git, qw(tag -s -m),
 852                        "Release $dversion for $csuite [dgit]");
 853         push @tag_cmd, qw(-u),$keyid if defined $keyid;
 854         push @tag_cmd, $tag;
 855         runcmd_ordryrun @tag_cmd;
 856         my @debsign_cmd = @debsign;
 857         push @debsign_cmd, "-k$keyid" if defined $keyid;
 858         push @debsign_cmd, $changesfile;
 859         runcmd_ordryrun @debsign_cmd;
 860     }
 861     runcmd_ordryrun @git, qw(push),access_giturl(),"refs/tags/$tag";
 862     my $host = access_cfg('upload-host','RETURN-UNDEF');
 863     my @hostarg = defined($host) ? ($host,) : ();
 864     runcmd_ordryrun @dput, @hostarg, $changesfile;
 865     printdone "pushed and uploaded $dversion";
 866 }
 867
 868 sub cmd_clone {
 869     parseopts();
 870     my $dstdir;
 871     badusage "-p is not allowed with clone; specify as argument instead"
 872         if defined $package;
 873     if (@ARGV==1) {
 874         ($package) = @ARGV;
 875     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
 876         ($package,$isuite) = @ARGV;
 877     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
 878         ($package,$dstdir) = @ARGV;
 879     } elsif (@ARGV==3) {
 880         ($package,$isuite,$dstdir) = @ARGV;
 881     } else {
 882         badusage "incorrect arguments to dgit clone";
 883     }
 884     $dstdir ||= "$package";
 885     clone($dstdir);
 886 }
 887
 888 sub branchsuite () {
 889     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
 890     if ($branch =~ m#$lbranch_re#o) {
 891         return $1;
 892     } else {
 893         return undef;
 894     }
 895 }
 896
 897 sub fetchpullargs () {
 898     if (!defined $package) {
 899         my $sourcep = parsecontrol('debian/control','debian/control');
 900         $package = getfield $sourcep, 'Source';
 901     }
 902     if (@ARGV==0) {
 903 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
 904         if (!$isuite) {
 905             my $clogp = parsechangelog();
 906             $isuite = getfield $clogp, 'Distribution';
 907         }
 908         canonicalise_suite();
 909         print "fetching from suite $csuite\n";
 910     } elsif (@ARGV==1) {
 911         ($isuite) = @ARGV;
 912         canonicalise_suite();
 913     } else {
 914         badusage "incorrect arguments to dgit fetch or dgit pull";
 915     }
 916 }
 917
 918 sub cmd_fetch {
 919     parseopts();
 920     fetchpullargs();
 921     fetch();
 922 }
 923
 924 sub cmd_pull {
 925     parseopts();
 926     fetchpullargs();
 927     pull();
 928 }
 929
 930 sub cmd_push {
 931     parseopts();
 932     badusage "-p is not allowed with dgit push" if defined $package;
 933     runcmd @git, qw(diff --quiet HEAD);
 934     my $clogp = parsechangelog();
 935     $package = getfield $clogp, 'Source';
 936     if (@ARGV==0) {
 937         $isuite = getfield $clogp, 'Distribution';
 938         if ($new_package) {
 939             local ($package) = $existing_package; # this is a hack
 940             canonicalise_suite();
 941         }
 942     } else {
 943         badusage "incorrect arguments to dgit push";
 944     }
 945     if (check_for_git()) {
 946         git_fetch_us();
 947     }
 948     if (fetch_from_archive()) {
 949         is_fast_fwd(lrref(), 'HEAD') or die;
 950     } else {
 951         $new_package or
 952             fail "package appears to be new in this suite;".
 953                 " if this is intentional, use --new";
 954     }
 955     dopush();
 956 }
 957
 958 sub cmd_build {
 959     # we pass further options and args to git-buildpackage
 960     badusage "-p is not allowed with dgit build" if defined $package;
 961     my $clogp = parsechangelog();
 962     $isuite = getfield $clogp, 'Distribution';
 963     $package = getfield $clogp, 'Source';
 964     my @cmd =
 965         (qw(git-buildpackage -us -uc --git-no-sign-tags),
 966          "--git-builder=@dpkgbuildpackage");
 967     unless (grep { m/^--git-debian-branch/ } @ARGV) {
 968         canonicalise_suite();
 969         push @cmd, "--git-debian-branch=".lbranch();
 970     }
 971     runcmd_ordryrun @cmd, @ARGV;
 972     printdone "build successful\n";
 973 }
 974
 975 sub cmd_sbuild {
 976     check_not_dirty();
 977     badusage "-p is not allowed with dgit sbuild" if defined $package;
 978     my $clogp = parsechangelog();
 979     $package = getfield $clogp, 'Source';
 980     my $isuite = getfield $clogp, 'Distribution';
 981     my $version = getfield $clogp, 'Version';
 982     my $sourcechanges = "${package}_${version}_source.changes";
 983     my $dscfn = dscfn($version);
 984     if ($build_use_dpkgbuildpackage) {
 985         runcmd_ordryrun (@dpkgbuildpackage, qw(-us -uc -S));
 986     } else {
 987         my $pwd = cmdoutput qw(env - pwd);
 988         my $leafdir = basename $pwd;
 989         chdir ".." or die $!;
 990         runcmd_ordryrun @dpkgsource, qw(-b --), $leafdir;
 991         chdir $pwd or die $!;
 992         runcmd_ordryrun qw(sh -ec),
 993             'exec >$1; shift; exec "$@"','x',
 994             $sourcechanges,
 995             qw(dpkg-genchanges -S);
 996     }
 997     chdir ".." or die $!;
 998     my $pat = "${package}_${version}_*.changes";
 999     if (!$dryrun) {
1000         stat $dscfn or fail "$dscfn (in parent directory): $!";
1001         stat $sourcechanges or fail "$sourcechanges (in parent directory): $!";
1002         foreach my $cf (glob $pat) {
1003             next if $cf eq $sourcechanges;
1004             unlink $cf or fail "remove $cf: $!";
1005         }
1006     }
1007     runcmd_ordryrun @sbuild, @ARGV, qw(-d), $isuite, $dscfn;
1008     runcmd_ordryrun @mergechanges, glob $pat;
1009     my $multichanges = "${package}_${version}_multi.changes";
1010     if (!$dryrun) {
1011         stat $multichanges or fail "$multichanges: $!";
1012     }
1013     printdone "build successful, results in $multichanges\n" or die $!;
1014 }
1015
1016 sub cmd_quilt_fixup {
1017     badusage "incorrect arguments to dgit quilt-fixup";
1018     my $clogp = parsechangelog();
1019     commit_quilty_patch((getfield $clogp, 'Version'));
1020 }
1021
1022 sub parseopts () {
1023     my $om;
1024     while (@ARGV) {
1025         last unless $ARGV[0] =~ m/^-/;
1026         $_ = shift @ARGV;
1027         last if m/^--?$/;
1028         if (m/^--/) {
1029             if (m/^--dry-run$/) {
1030                 $dryrun=1;
1031             } elsif (m/^--no-sign$/) {
1032                 $sign=0;
1033             } elsif (m/^--help$/) {
1034                 helponly();
1035             } elsif (m/^--new$/) {
1036                 $new_package=1;
1037             } elsif (m/^--(\w+)=(.*)/s && ($om = $opts_opt_map{$1})) {
1038                 $om->[0] = $2;
1039             } elsif (m/^--(\w+):(.*)/s && ($om = $opts_opt_map{$1})) {
1040                 push @$om, $2;
1041             } elsif (m/^--existing-package=(.*)/s) {
1042                 $existing_package = $1;
1043             } elsif (m/^--distro=(.*)/s) {
1044                 $idistro = $1;
1045             } else {
1046                 badusage "unknown long option \`$_'";
1047             }
1048         } else {
1049             while (m/^-./s) {
1050                 if (s/^-n/-/) {
1051                     $dryrun=1;
1052                 } elsif (s/^-h/-/) {
1053                     helponly();
1054                 } elsif (s/^-D/-/) {
1055                     open DEBUG, ">&STDERR" or die $!;
1056                     $debug++;
1057                 } elsif (s/^-N/-/) {
1058                     $new_package=1;
1059                 } elsif (s/^-c(.*=.*)//s) {
1060                     push @git, '-c', $1;
1061                 } elsif (s/^-d(.*)//s) {
1062                     $idistro = $1;
1063                 } elsif (s/^-C(.*)//s) {
1064                     $changesfile = $1;
1065                 } elsif (s/^-k(.*)//s) {
1066                     $keyid=$1;
1067                 } else {
1068                     badusage "unknown short option \`$_'";
1069                 }
1070             }
1071         }
1072     }
1073 }
1074
1075 parseopts();
1076 print STDERR "DRY RUN ONLY\n" if $dryrun;
1077 if (!@ARGV) {
1078     print STDERR $helpmsg or die $!;
1079     exit 8;
1080 }
1081 my $cmd = shift @ARGV;
1082 $cmd =~ y/-/_/;
1083 { no strict qw(refs); &{"cmd_$cmd"}(); }