dgit

   1 #!/usr/bin/perl -w
   2 use strict;
   3
   4 use IO::Handle;
   5 use Data::Dumper;
   6 use LWP::UserAgent;
   7 use Dpkg::Control::Hash;
   8
   9 open DEBUG, ">&STDERR" or die $!;
  10
  11 our $pdo = 'http://packages.debian.org/';
  12 #our $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/';
  13 our $suite = 'sid';
  14 our $package = 'userv';
  15
  16 our $aliothname = 'iwj@git.debian.org';
  17 our $aliothpath = '/git/dgit-test';
  18 our $alioth_git = 'git+ssh://$aliothname/$aliothpath';
  19 our $alioth_sshtestbodge = [$aliothname,$aliothpath];
  20
  21 sub mainbranch () { return "$suite"; }
  22 sub uploadingbranch () { return "uploading/$suite"; }
  23
  24 sub url_get {
  25     if (!$ua) {
  26         $ua = LWP::UserAgent->new;
  27         $ua->env_proxy;
  28     }
  29 print DEBUG "fetching @_...\n";
  30     my $r = $ua->get(@_) or die $!;
  31     die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
  32     return $r->decoded_content();
  33 }
  34
  35 sub get_archive_dsc () {
  36     my $pdourl = "$pdo/source/$suite/$package";
  37     my $pdodata = url_get($pdourl);
  38     # FFS.  The Debian archive has no sane way to find what
  39     # version is currently the tip in any branch (aka, what
  40     # is the current version in any suite).
  41     $pdodata =~ m{
  42         Download\ \Q$package\E .*
  43         \<a\ href=\"([^"&]+([^"/]+\.dsc))\"\>\2\</a\>
  44     }msx
  45         or die "screenscraping of $pdourl failed :-(\n";
  46     my $dscurl = $1;
  47 print DEBUG Dumper($pdodata, $&, $dscurl);
  48     my $dscdata = url_get($dscurl);
  49     my $dscfh = new IO::File \$dscdata, '<' or die $!;
  50 print DEBUG Dumper($dscdata, $dscfh);
  51     my $dscp = Dpkg::Control::Hash->new(allow_pgp=>1);
  52     $dscp->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
  53     mu $dscf = $dscp->{'fields'};
  54     die "unsupported format $dscf->{Format}, sorry\n"
  55         unless $dscf->{Format} eq '1.0';
  56     return $dsc;
  57 }
  58
  59 sub check_for_git () {
  60     # returns 0 or 1
  61     open P, "ssh $alioth_sshtestbodge->[0] '".
  62         "set -e; cd /git/dgit-test;".
  63         "if test -d $package.git; then echo 1; else echo 0; fi".
  64         "' |"
  65         or die $!;
  66     $!=0; $?=0;
  67     my $r = <P>; close P;
  68     die "$r $! $?" unless $r =~ m/^[01]$/;
  69     return !!$r;
  70 }
  71
  72 sub runcmd {
  73     $!=0; $?=0;
  74     die "$! $?" if system @_;
  75 }
  76
  77 our ($dsc,$dsc_hash);
  78
  79 sub combine () {
  80     if (defined $dsc_hash) {
  81
  82
  83         open P, "-|", qw(git rev-parse --), $dsc_hash;
  84
  85 }
  86
  87 sub clone () {
  88     $dsc = get_archive_dsc();
  89     $dsc_hash = $dsc->{Vcs-git-master};
  90     if (defined $dsh_hash) {
  91         $dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
  92         $dsc_hash = $&;
  93     }
  94     my $dstdir = "$package";
  95     if (check_for_git()) {
  96         runcmd qw(git clone --origin dgit -b), $suite, '--',
  97             $alioth_git, $dstdir;
  98         chdir "$dstdir" or die "$dstdir $!";
  99         combine();
 100     } else {
 101         mkdir $dstdir or die "$dstdir $!";
 102         chdir "$dstdir" or die "$dstdir $!";
 103         runcmd qw(git init);
 104         open H, "> .git/refs/HEAD" or die $!;
 105         print H "ref: refs/heads/$suite\n" or die $!;
 106         close H or die $!;
 107         runcmd qw(git remote add dgit), $alioth_git;
 108         runcmd "git config branch.$suite.remote dgit";
 109         runcmd "git config branch.$suite.merge refs/heads/$suite";
 110         combine();
 111     }
 112 }
 113
 114 sub fetch () {
 115     my ($archive_or_mirror, $suite, $package) = @_;
 116     my $dsc = get_archive_dsc();
 117
 118     with_tmpdir($td,{
 119
 120     });
 121
 122 print Dumper(get_archive_dsc());