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