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 Dpkg::Version;
  28 use POSIX;
  29
  30 our $isuite = 'unstable';
  31 our $package;
  32
  33 our $sign = 1;
  34 our $dryrun = 0;
  35 our $changesfile;
  36 our $new_package = 0;
  37 our $existing_package = 'dpkg';
  38
  39 our %format_ok = map { $_=>1 } ("1.0","3.0 (native)","3.0 (quilt)");
  40
  41 our (@git) = qw(git);
  42 our (@dget) = qw(dget);
  43 our (@dput) = qw(dput);
  44 our (@debsign) = qw(debsign);
  45 our $keyid;
  46
  47 our $debug = 0;
  48 open DEBUG, ">/dev/null" or die $!;
  49
  50 our %opts_opt_map = ('dget' => \@dget,
  51                      'dput' => \@dput,
  52                      'debsign' => \@debsign);
  53
  54 our $remotename = 'dgit';
  55 our $ourdscfield = 'Vcs-Dgit-Master';
  56 our $branchprefix = 'dgit';
  57 our $csuite;
  58
  59 sub lbranch () { return "$branchprefix/$csuite"; }
  60 my $lbranch_re = '^refs/heads/'.$branchprefix.'/([^/.]+)$';
  61 sub lref () { return "refs/heads/".lbranch(); }
  62 sub lrref () { return "refs/remotes/$remotename/$csuite"; }
  63 sub rrref () { return "refs/$branchprefix/$csuite"; }
  64 sub debiantag ($) { return "debian/$_[0]"; }
  65
  66 sub fetchspec () {
  67     local $csuite = '*';
  68     return  "+".rrref().":".lrref();
  69 }
  70
  71 our $ua;
  72
  73 sub url_get {
  74     if (!$ua) {
  75         $ua = LWP::UserAgent->new();
  76         $ua->env_proxy;
  77     }
  78     print "downloading @_...\n";
  79     my $r = $ua->get(@_) or die $!;
  80     die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
  81     return $r->decoded_content();
  82 }
  83
  84 our ($dscdata,$dscurl,$dsc);
  85
  86 sub printcmd {
  87     my $fh = shift @_;
  88     my $intro = shift @_;
  89     print $fh $intro or die $!;
  90     local $_;
  91     foreach my $a (@_) {
  92         $_ = $a;
  93         if (s{['\\]}{\\$&}g || m{\s} || m{[^-_./0-9a-z]}i) {
  94             print $fh " '$_'" or die $!;
  95         } else {
  96             print $fh " $_" or die $!;
  97         }
  98     }
  99     print $fh "\n" or die $!;
 100 }
 101
 102 sub runcmd {
 103     printcmd(\*DEBUG,"+",@_) if $debug>0;
 104     $!=0; $?=0;
 105     die "@_ $! $?" if system @_;
 106 }
 107
 108 sub printdone {
 109     if (!$dryrun) {
 110         print "dgit ok: @_\n";
 111     } else {
 112         print "would be ok: @_ (but dry run only)\n";
 113     }
 114 }
 115
 116 sub cmdoutput_errok {
 117     die Dumper(\@_)." ?" if grep { !defined } @_;
 118     printcmd(\*DEBUG,"|",@_) if $debug>0;
 119     open P, "-|", @_ or die $!;
 120     my $d;
 121     $!=0; $?=0;
 122     { local $/ = undef; $d = <P>; }
 123     die if P->error;
 124     if (!close P) { print DEBUG "=>!$?\n" if $debug>0; return undef; }
 125     chomp $d;
 126     $d =~ m/^.*/;
 127     print DEBUG "=> \`$&'",(length $' ? '...' : ''),"\n" if $debug>0; #';
 128     return $d;
 129 }
 130
 131 sub cmdoutput {
 132     my $d = cmdoutput_errok @_;
 133     defined $d or die "@_ $? $!";
 134     return $d;
 135 }
 136
 137 sub dryrun_report {
 138     printcmd(\*STDOUT,"#",@_);
 139 }
 140
 141 sub runcmd_ordryrun {
 142     if (!$dryrun) {
 143         runcmd @_;
 144     } else {
 145         dryrun_report @_;
 146     }
 147 }
 148
 149 our %defcfg = ('dgit.default.distro' => 'debian',
 150                'dgit.default.username' => '',
 151                'dgit.default.archive-query-default-component' => 'main',
 152                'dgit.default.ssh' => 'ssh',
 153                'dgit-distro.debian.git-host' => 'git.debian.org',
 154                'dgit-distro.debian.git-proto' => 'git+ssh://',
 155                'dgit-distro.debian.git-path' => '/git/dgit-repos',
 156                'dgit-distro.debian.git-check' => 'ssh-cmd',
 157                'dgit-distro.debian.git-create' => 'ssh-cmd',
 158                'dgit-distro.debian.sshdakls-host' => 'coccia.debian.org',
 159                'dgit-distro.debian.sshdakls-dir' =>
 160                    '/srv/ftp-master.debian.org/ftp/dists',
 161                'dgit-distro.debian.mirror' => 'http://http.debian.net/debian/');
 162
 163 sub cfg {
 164     foreach my $c (@_) {
 165         my $v;
 166         {
 167             local ($debug) = $debug-1;
 168             $v = cmdoutput_errok(@git, qw(config --), $c);
 169         };
 170         if ($?==0) {
 171             return $v;
 172         } elsif ($?!=256) {
 173             die "$c $?";
 174         }
 175         my $dv = $defcfg{$c};
 176         return $dv if defined $dv;
 177     }
 178     return undef;
 179 }
 180
 181 sub access_distro () {
 182     return cfg("dgit-suite.$isuite.distro",
 183                "dgit.default.distro");
 184 }
 185
 186 sub access_cfg (@) {
 187     my (@keys) = @_;
 188     my $distro = access_distro();
 189     my $value = cfg(map { ("dgit-distro.$distro.$_",
 190                            "dgit.default.$_") } @keys);
 191     return $value;
 192 }
 193
 194 sub access_someuserhost ($) {
 195     my ($some) = @_;
 196     my $user = access_cfg("$some-user",'username');
 197     my $host = access_cfg("$some-host");
 198     return defined($user) && length($user) ? "$user\@$host" : $host;
 199 }
 200
 201 sub access_gituserhost () {
 202     return access_someuserhost('git');
 203 }
 204
 205 sub access_giturl () {
 206     my $url = access_cfg('git-url');
 207     if (!defined $url) {
 208         $url =
 209             access_cfg('git-proto').
 210             access_gituserhost().
 211             access_cfg('git-path');
 212     }
 213     return "$url/$package.git";
 214 }
 215
 216 sub parsecontrol {
 217     my $c = Dpkg::Control::Hash->new();
 218     $c->load(@_) or return undef;
 219     return $c;
 220 }
 221
 222 sub parsechangelog {
 223     my $c = Dpkg::Control::Hash->new();
 224     my $p = new IO::Handle;
 225     open $p, '-|', qw(dpkg-parsechangelog) or die $!;
 226     $c->parse($p);
 227     $?=0; $!=0; close $p or die "$! $?";
 228     return $c;
 229 }
 230
 231 our %rmad;
 232
 233 sub archive_query ($) {
 234     my ($method) = @_;
 235     my $query = access_cfg('archive-query');
 236     if (!$query) {
 237         my $distro = access_distro();
 238         if ($distro eq 'debian') {
 239             $query = "sshdakls:".
 240                 access_someuserhost('sshdakls').':'.
 241                 access_cfg('sshdakls-dir');
 242         } else {
 243             $query = "madison:$distro";
 244         }
 245     }
 246     $query =~ s/^(\w+):// or die "$query ?";
 247     my $proto = $1;
 248     my $data = $'; #';
 249     { no strict qw(refs); &{"${method}_${proto}"}($proto,$data); }
 250 }
 251
 252 sub archive_query_madison ($$) {
 253     my ($proto,$data) = @_;
 254     die unless $proto eq 'madison';
 255     $rmad{$package} ||= cmdoutput
 256         qw(rmadison -asource),"-s$isuite","-u$data",$package;
 257     my $rmad = $rmad{$package};
 258     return madison_parse($rmad);
 259 }
 260
 261 sub archive_query_sshdakls ($$) {
 262     my ($proto,$data) = @_;
 263     $data =~ s/:.*// or die "$data ?";
 264     my $dakls = cmdoutput
 265         access_cfg('ssh'), $data, qw(dak ls -asource),"-s$isuite",$package;
 266     return madison_parse($dakls);
 267 }
 268
 269 sub canonicalise_suite_sshdakls ($$) {
 270     my ($proto,$data) = @_;
 271     $data =~ m/:/ or die "$data ?";
 272     my $dakls = cmdoutput
 273         access_cfg('ssh'), $`,
 274         "set -e; cd $';".
 275         " if test -h $isuite; then readlink $isuite; exit 0; fi;".
 276         " if test -d $isuite; then echo $isuite; exit 0; fi;".
 277         " exit 1";
 278     die unless $dakls =~ m/^\w/;
 279     return $dakls;
 280 }
 281
 282 sub madison_parse ($) {
 283     my ($rmad) = @_;
 284     if (!length $rmad) {
 285         return ();
 286     }
 287     $rmad =~ m{^ \s*( [^ \t|]+ )\s* \|
 288                  \s*( [^ \t|]+ )\s* \|
 289                  \s*( [^ \t|/]+ )(?:/([^ \t|/]+))? \s* \|
 290                  \s*( [^ \t|]+ )\s* }x or die "$rmad $?";
 291     $1 eq $package or die "$rmad $package ?";
 292     my $vsn = $2;
 293     my $newsuite = $3;
 294     my $component;
 295     if (defined $4) {
 296         $component = $4;
 297     } else {
 298         $component = access_cfg('archive-query-default-component');
 299     }
 300     $5 eq 'source' or die "$rmad ?";
 301     my $prefix = substr($package, 0, $package =~ m/^l/ ? 4 : 1);
 302     my $subpath = "/pool/$component/$prefix/$package/${package}_$vsn.dsc";
 303     return ($vsn,$subpath,$newsuite);
 304 }
 305
 306 sub canonicalise_suite_madison ($$) {
 307     my @r = archive_query_madison($_[0],$_[1]);
 308     @r or die;
 309     return $r[2];
 310 }
 311
 312 sub canonicalise_suite () {
 313     $csuite = archive_query('canonicalise_suite');
 314     if ($isuite ne $csuite) {
 315         # madison canonicalises for us
 316         print "canonical suite name for $isuite is $csuite\n";
 317     }
 318 }
 319
 320 sub get_archive_dsc () {
 321     my ($vsn,$subpath) = archive_query('archive_query');
 322     canonicalise_suite();
 323     if (!defined $vsn) { $dsc=undef; return undef; }
 324     $dscurl = access_cfg('mirror').$subpath;
 325     $dscdata = url_get($dscurl);
 326     my $dscfh = new IO::File \$dscdata, '<' or die $!;
 327     print DEBUG Dumper($dscdata) if $debug>1;
 328     $dsc = Dpkg::Control::Hash->new(allow_pgp=>1);
 329     $dsc->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
 330     print DEBUG Dumper($dsc) if $debug>1;
 331     my $fmt = $dsc->{Format};
 332     die "unsupported format $fmt, sorry\n" unless $format_ok{$fmt};
 333 }
 334
 335 sub check_for_git () {
 336     # returns 0 or 1
 337     my $how = access_cfg('git-check');
 338     if ($how eq 'ssh-cmd') {
 339         my $r= cmdoutput
 340             (access_cfg('ssh'),access_gituserhost(),
 341              " set -e; cd ".access_cfg('git-path').";".
 342              " if test -d $package.git; then echo 1; else echo 0; fi");
 343         die "$r $! $?" unless $r =~ m/^[01]$/;
 344         return $r+0;
 345     } else {
 346         die "unknown git-check $how ?";
 347     }
 348 }
 349
 350 sub create_remote_git_repo () {
 351     my $how = access_cfg('git-create');
 352     if ($how eq 'ssh-cmd') {
 353         runcmd_ordryrun
 354             (access_cfg('ssh'),access_gituserhost(),
 355              "set -e; cd ".access_cfg('git-path').";".
 356              " mkdir -p $package.git;".
 357              " cd $package.git;".
 358              " if ! test -d objects; then git init --bare; fi");
 359     } else {
 360         die "unknown git-create $how ?";
 361     }
 362 }
 363
 364 our ($dsc_hash,$upload_hash);
 365
 366 our $ud = '.git/dgit/unpack';
 367
 368 sub prep_ud () {
 369     rmtree($ud);
 370     mkpath '.git/dgit';
 371     mkdir $ud or die $!;
 372 }
 373
 374 sub mktree_in_ud_from_only_subdir () {
 375     # changes into the subdir
 376     my (@dirs) = <*/.>;
 377     die unless @dirs==1;
 378     $dirs[0] =~ m#^([^/]+)/\.$# or die;
 379     my $dir = $1;
 380     chdir $dir or die "$dir $!";
 381     die if stat '.git';
 382     die $! unless $!==&ENOENT;
 383     runcmd qw(git init -q);
 384     rmtree('.git/objects');
 385     symlink '../../../../objects','.git/objects' or die $!;
 386     runcmd @git, qw(add -Af);
 387     my $tree = cmdoutput @git, qw(write-tree);
 388     $tree =~ m/^\w+$/ or die "$tree ?";
 389     return ($tree,$dir);
 390 }
 391
 392 sub dsc_files () {
 393     map {
 394         m/^\w+ \d+ (\S+)$/ or die "$_ ?";
 395         $1;
 396     } grep m/\S/, split /\n/, ($dsc->{'Checksums-Sha256'} || $dsc->{Files});
 397 }
 398
 399 sub is_orig_file ($) {
 400     local ($_) = @_;
 401     m/\.orig(?:-\w+)?\.tar\.\w+$/;
 402 }
 403
 404 sub make_commit ($) {
 405     my ($file) = @_;
 406     return cmdoutput @git, qw(hash-object -w -t commit), $file;
 407 }
 408
 409 sub generate_commit_from_dsc () {
 410     prep_ud();
 411     chdir $ud or die $!;
 412     my @files;
 413     foreach my $f (dsc_files()) {
 414         die if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
 415         push @files, $f;
 416         link "../../../$f", $f
 417             or $!==&ENOENT
 418             or die "$f $!";
 419     }
 420     runcmd @dget, qw(--), $dscurl;
 421     foreach my $f (grep { is_orig_file($_) } @files) {
 422         link $f, "../../../../$f"
 423             or $!==&EEXIST
 424             or die "$f $!";
 425     }
 426     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
 427     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
 428     my $clogp = parsecontrol('../changelog.tmp','changelog') or die;
 429     my $date = cmdoutput qw(date), '+%s %z', qw(-d),$clogp->{Date};
 430     my $author = $clogp->{Maintainer};
 431     $author =~ s#,.*##ms;
 432     my $authline = "$author $date";
 433     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or die $authline;
 434     open C, ">../commit.tmp" or die $!;
 435     print C <<END or die $!;
 436 tree $tree
 437 author $authline
 438 committer $authline
 439
 440 $clogp->{Changes}
 441
 442 # imported from the archive
 443 END
 444     close C or die $!;
 445     my $outputhash = make_commit qw(../commit.tmp);
 446     print "synthesised git commit from .dsc $clogp->{Version}\n";
 447     if ($upload_hash) {
 448         runcmd @git, qw(reset --hard), $upload_hash;
 449         runcmd qw(sh -ec), 'dpkg-parsechangelog >>../changelogold.tmp';
 450         my $oldclogp = Dpkg::Control::Hash->new();
 451         $oldclogp->load('../changelogold.tmp','previous changelog') or die;
 452         my $vcmp =
 453             version_compare_string($oldclogp->{Version}, $clogp->{Version});
 454         if ($vcmp < 0) {
 455             # git upload/ is earlier vsn than archive, use archive
 456             open C, ">../commit2.tmp" or die $!;
 457             print C <<END or die $!;
 458 tree $tree
 459 parent $upload_hash
 460 parent $outputhash
 461 author $authline
 462 committer $authline
 463
 464 Record $package ($clogp->{Version}) in archive suite $csuite
 465 END
 466             $outputhash = make_commit qw(../commit2.tmp);
 467         } elsif ($vcmp > 0) {
 468             print STDERR <<END or die $!;
 469 Version actually in archive:    $clogp->{Version} (older)
 470 Last allegedly pushed/uploaded: $oldclogp->{Version} (newer or same)
 471 Perhaps the upload is stuck in incoming.  Using the version from git.
 472 END
 473             $outputhash = $upload_hash;
 474         } elsif ($outputhash ne $upload_hash) {
 475             die "version in archive ($clogp->{Version})".
 476                 " is same as version in git".
 477                 " to-be-uploaded (upload/) branch ($oldclogp->{Version})".
 478                 " but archive version hash no commit hash?!\n";
 479         }
 480     }
 481     chdir '../../../..' or die $!;
 482     runcmd @git, qw(update-ref -m),"dgit fetch import $clogp->{Version}",
 483             'DGIT_ARCHIVE', $outputhash;
 484     cmdoutput @git, qw(log -n2), $outputhash;
 485     # ... gives git a chance to complain if our commit is malformed
 486     rmtree($ud);
 487     return $outputhash;
 488 }
 489
 490 sub ensure_we_have_orig () {
 491     foreach my $f (dsc_files()) {
 492         next unless is_orig_file($f);
 493         if (stat "../$f") {
 494             die "$f ?" unless -f _;
 495         } else {
 496             die "$f $!" unless $!==&ENOENT;
 497         }
 498         my $origurl = $dscurl;
 499         $origurl =~ s{/[^/]+$}{};
 500         $origurl .= "/$f";
 501         die "$f ?" unless $f =~ m/^${package}_/;
 502         die "$f ?" if $f =~ m#/#;
 503         runcmd_ordryrun qw(sh -ec),'cd ..; exec "$@"','x',
 504             @dget,'--',$origurl;
 505     }
 506 }
 507
 508 sub rev_parse ($) {
 509     return cmdoutput @git, qw(rev-parse), "$_[0]~0";
 510 }
 511
 512 sub is_fast_fwd ($$) {
 513     my ($ancestor,$child) = @_;
 514     my $mb = cmdoutput @git, qw(merge-base), $ancestor, $child;
 515     return rev_parse($mb) eq rev_parse($ancestor);
 516 }
 517
 518 sub git_fetch_us () {
 519     die "cannot dry run with fetch" if $dryrun;
 520     runcmd @git, qw(fetch),access_giturl(),fetchspec();
 521 }
 522
 523 sub fetch_from_archive () {
 524     # ensures that lrref() is what is actually in the archive,
 525     #  one way or another
 526     get_archive_dsc() or return 0;
 527     $dsc_hash = $dsc->{$ourdscfield};
 528     if (defined $dsc_hash) {
 529         $dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
 530         $dsc_hash = $&;
 531         print "last upload to archive specified git hash\n";
 532     } else {
 533         print "last upload to archive has NO git hash\n";
 534     }
 535
 536     my $lrref_fn = ".git/".lrref();
 537     if (open H, $lrref_fn) {
 538         $upload_hash = <H>;
 539         chomp $upload_hash;
 540         die "$lrref_fn $upload_hash ?" unless $upload_hash =~ m/^\w+$/;
 541     } elsif ($! == &ENOENT) {
 542         $upload_hash = '';
 543     } else {
 544         die "$lrref_fn $!";
 545     }
 546     print DEBUG "previous reference hash $upload_hash\n";
 547     my $hash;
 548     if (defined $dsc_hash) {
 549         die "missing git history even though dsc has hash"
 550             unless $upload_hash;
 551         $hash = $dsc_hash;
 552         ensure_we_have_orig();
 553     } else {
 554         $hash = generate_commit_from_dsc();
 555     }
 556     print DEBUG "current hash $hash\n";
 557     if ($upload_hash) {
 558         die "not fast forward on last upload branch!".
 559             " (archive's version left in DGIT_ARCHIVE)"
 560             unless is_fast_fwd($upload_hash, $hash);
 561     }
 562     if ($upload_hash ne $hash) {
 563         my @upd_cmd = (@git, qw(update-ref -m), 'dgit fetch', lrref(), $hash);
 564         if (!$dryrun) {
 565             cmdoutput @upd_cmd;
 566         } else {
 567             dryrun_report @upd_cmd;
 568         }
 569     }
 570     return 1;
 571 }
 572
 573 sub clone ($) {
 574     my ($dstdir) = @_;
 575     canonicalise_suite();
 576     die "dry run makes no sense with clone" if $dryrun;
 577     mkdir $dstdir or die "$dstdir $!";
 578     chdir "$dstdir" or die "$dstdir $!";
 579     runcmd @git, qw(init -q);
 580     runcmd @git, qw(config), "remote.$remotename.fetch", fetchspec();
 581     open H, "> .git/HEAD" or die $!;
 582     print H "ref: ".lref()."\n" or die $!;
 583     close H or die $!;
 584     runcmd @git, qw(remote add), 'origin', access_giturl();
 585     if (check_for_git()) {
 586         print "fetching existing git history\n";
 587         git_fetch_us();
 588         runcmd @git, qw(fetch origin);
 589     } else {
 590         print "starting new git history\n";
 591     }
 592     fetch_from_archive() or die;
 593     runcmd @git, qw(reset --hard), lrref();
 594     printdone "ready for work in $dstdir";
 595 }
 596
 597 sub fetch () {
 598     if (check_for_git()) {
 599         git_fetch_us();
 600     }
 601     fetch_from_archive() or die;
 602     printdone "fetched into ".lrref();
 603 }
 604
 605 sub pull () {
 606     fetch();
 607     runcmd_ordryrun @git, qw(merge -m),"Merge from $csuite [dgit]",
 608         lrref();
 609     printdone "fetched to ".lrref()." and merged into HEAD";
 610 }
 611
 612 sub check_not_dirty () {
 613     runcmd @git, qw(diff --quiet);
 614 }
 615
 616 sub commit_quilty_patch ($) {
 617     my ($vsn) = @_;
 618     my $output = cmdoutput @git, qw(status --porcelain);
 619     my %fixups = map {$_=>1}
 620         (".pc/debian-changes-$vsn/","debian/patches/debian-changes-$vsn");
 621     my @files;
 622     foreach my $l (split /\n/, $output) {
 623         next unless $l =~ s/^\?\? //;
 624         next unless $fixups{$l};
 625         push @files, $l;
 626     }
 627     print DEBUG "checking for quilty\n", Dumper(\@files);
 628     if (@files == 2) {
 629         my $m = "Commit Debian 3.0 (quilt) metadata";
 630         print "$m\n";
 631         runcmd_ordryrun @git, qw(add), @files;
 632         runcmd_ordryrun @git, qw(commit -m), $m;
 633     }
 634 }
 635
 636 sub dopush () {
 637     print DEBUG "actually entering push\n";
 638     my $clogp = parsechangelog();
 639     $package = $clogp->{Source};
 640     my $dscfn = "${package}_$clogp->{Version}.dsc";
 641     stat "../$dscfn" or die "$dscfn $!";
 642     $dsc = parsecontrol("../$dscfn");
 643     print DEBUG "format $dsc->{Format}\n";
 644     if ($dsc->{Format} eq '3.0 (quilt)') {
 645         print "Format \`$dsc->{Format}', urgh\n";
 646         commit_quilty_patch($dsc->{Version});
 647     }
 648     check_not_dirty();
 649     prep_ud();
 650     chdir $ud or die $!;
 651     print "checking that $dscfn corresponds to HEAD\n";
 652     runcmd qw(dpkg-source -x --), "../../../../$dscfn";
 653     my ($tree,$dir) = mktree_in_ud_from_only_subdir();
 654     chdir '../../../..' or die $!;
 655     runcmd @git, qw(diff --exit-code), $tree;
 656 #fetch from alioth
 657 #do fast forward check and maybe fake merge
 658 #    if (!is_fast_fwd(mainbranch
 659 #    runcmd @git, qw(fetch -p ), "$alioth_git/$package.git",
 660 #        map { lref($_).":".rref($_) }
 661 #        (uploadbranch());
 662     $dsc->{$ourdscfield} = rev_parse('HEAD');
 663     $dsc->save("../$dscfn.tmp") or die $!;
 664     if (!$dryrun) {
 665         rename "../$dscfn.tmp","../$dscfn" or die "$dscfn $!";
 666     } else {
 667         print "[new .dsc left in $dscfn.tmp]\n";
 668     }
 669     if (!$changesfile) {
 670         my $pat = "../${package}_$clogp->{Version}_*.changes";
 671         my @cs = glob $pat;
 672         die "$pat ?" unless @cs==1;
 673         ($changesfile) = @cs;
 674     }
 675     my $tag = debiantag($dsc->{Version});
 676     if (!check_for_git()) {
 677         create_remote_git_repo();
 678     }
 679     runcmd_ordryrun @git, qw(push),access_giturl(),"HEAD:".rrref();
 680     if ($sign) {
 681         my @tag_cmd = (@git, qw(tag -s -m),
 682                        "Release $dsc->{Version} for $csuite [dgit]");
 683         push @tag_cmd, qw(-u),$keyid if defined $keyid;
 684         push @tag_cmd, $tag;
 685         runcmd_ordryrun @tag_cmd;
 686         my @debsign_cmd = @debsign;
 687         push @debsign_cmd, "-k$keyid" if defined $keyid;
 688         push @debsign_cmd, $changesfile;
 689         runcmd_ordryrun @debsign_cmd;
 690     }
 691     runcmd_ordryrun @git, qw(push),access_giturl(),"refs/tags/$tag";
 692     my $host = access_cfg('upload-host');
 693     my @hostarg = defined($host) ? ($host,) : ();
 694     runcmd_ordryrun @dput, @hostarg, $changesfile;
 695     printdone "pushed and uploaded $dsc->{Version}";
 696 }
 697
 698 sub cmd_clone {
 699     parseopts();
 700     my $dstdir;
 701     die if defined $package;
 702     if (@ARGV==1) {
 703         ($package) = @ARGV;
 704     } elsif (@ARGV==2 && $ARGV[1] =~ m#^\w#) {
 705         ($package,$isuite) = @ARGV;
 706     } elsif (@ARGV==2 && $ARGV[1] =~ m#^[./]#) {
 707         ($package,$dstdir) = @ARGV;
 708     } elsif (@ARGV==3) {
 709         ($package,$isuite,$dstdir) = @ARGV;
 710     } else {
 711         die;
 712     }
 713     $dstdir ||= "$package";
 714     clone($dstdir);
 715 }
 716
 717 sub branchsuite () {
 718     my $branch = cmdoutput_errok @git, qw(symbolic-ref HEAD);
 719     if ($branch =~ m#$lbranch_re#o) {
 720         return $1;
 721     } else {
 722         return undef;
 723     }
 724 }
 725
 726 sub fetchpullargs () {
 727     if (!defined $package) {
 728         my $sourcep = parsecontrol('debian/control');
 729         $package = $sourcep->{Source};
 730     }
 731     if (@ARGV==0) {
 732 #       $isuite = branchsuite();  # this doesn't work because dak hates canons
 733         if (!$isuite) {
 734             my $clogp = parsechangelog();
 735             $isuite = $clogp->{Distribution};
 736         }
 737         canonicalise_suite();
 738         print "fetching from suite $csuite\n";
 739     } elsif (@ARGV==1) {
 740         ($isuite) = @ARGV;
 741         canonicalise_suite();
 742     } else {
 743         die;
 744     }
 745 }
 746
 747 sub cmd_fetch {
 748     parseopts();
 749     fetchpullargs();
 750     fetch();
 751 }
 752
 753 sub cmd_pull {
 754     parseopts();
 755     fetchpullargs();
 756     pull();
 757 }
 758
 759 sub cmd_push {
 760     parseopts();
 761     die if defined $package;
 762     runcmd @git, qw(diff --quiet HEAD);
 763     my $clogp = parsechangelog();
 764     $package = $clogp->{Source};
 765     if (@ARGV==0) {
 766         $isuite = $clogp->{Distribution};
 767         if ($new_package) {
 768             local ($package) = $existing_package; # this is a hack
 769             canonicalise_suite();
 770         }
 771     } else {
 772         die;
 773     }
 774     if (fetch_from_archive()) {
 775         is_fast_fwd(lrref(), 'HEAD') or die;
 776     } else {
 777         die unless $new_package;
 778     }
 779     dopush();
 780 }
 781
 782 sub cmd_build {
 783     # we pass further options and args to git-buildpackage
 784     die if defined $package;
 785     my $clogp = parsechangelog();
 786     $isuite = $clogp->{Distribution};
 787     $package = $clogp->{Source};
 788     my @cmd =
 789         (qw(git-buildpackage -us -uc --git-no-sign-tags),
 790          '--git-builder=dpkg-buildpackage -i\.git/ -I.git');
 791     unless (grep { m/^--git-debian-branch/ } @ARGV) {
 792         canonicalise_suite();
 793         push @cmd, "--git-debian-branch=".lbranch();
 794     }
 795     runcmd_ordryrun @cmd, @ARGV;
 796 }
 797
 798 sub cmd_quilt_fixup {
 799     die if @ARGV;
 800     my $clogp = parsechangelog();
 801     commit_quilty_patch($clogp->{Version});
 802 }
 803
 804 sub parseopts () {
 805     my $om;
 806     while (@ARGV) {
 807         last unless $ARGV[0] =~ m/^-/;
 808         $_ = shift @ARGV;
 809         last if m/^--?$/;
 810         if (m/^--/) {
 811             if (m/^--dry-run$/) {
 812                 $dryrun=1;
 813             } elsif (m/^--no-sign$/) {
 814                 $sign=0;
 815             } elsif (m/^--new$/) {
 816                 $new_package=1;
 817             } elsif (m/^--(\w+)=(.*)/s && ($om = $opts_opt_map{$1})) {
 818                 $om->[0] = $2;
 819             } elsif (m/^--(\w+):(.*)/s && ($om = $opts_opt_map{$1})) {
 820                 push @$om, $2;
 821             } elsif (m/^--existing-package=(.*)/s) {
 822                 $existing_package = $1;
 823             } else {
 824                 die "$_ ?";
 825             }
 826         } else {
 827             while (m/^-./s) {
 828                 if (s/^-n/-/) {
 829                     $dryrun=1;
 830                 } elsif (s/^-D/-/) {
 831                     open DEBUG, ">&STDERR" or die $!;
 832                     $debug++;
 833                 } elsif (s/^-N/-/) {
 834                     $new_package=1;
 835                 } elsif (s/^-c(.*=.*)//s) {
 836                     push @git, '-c', $1;
 837                 } elsif (s/^-C(.*)//s) {
 838                     $changesfile = $1;
 839                 } elsif (s/^-k(.*)//s) {
 840                     $keyid=$1;
 841                 } else {
 842                     die "$_ ?";
 843                 }
 844             }
 845         }
 846     }
 847 }
 848
 849 parseopts();
 850 print STDERR "DRY RUN ONLY\n" if $dryrun;
 851 die unless @ARGV;
 852 my $cmd = shift @ARGV;
 853 $cmd =~ y/-/_/;
 854 { no strict qw(refs); &{"cmd_$cmd"}(); }