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