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 use File::Path;
   9 use POSIX;
  10
  11 open DEBUG, ">&STDERR" or die $!;
  12
  13 our $pdo = 'http://packages.debian.org/';
  14 #our $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/';
  15 our $suite = 'sid';
  16 our $package = '2vcard';
  17
  18 our $aliothname = 'iwj@git.debian.org';
  19 our $aliothpath = '/git/dgit-test';
  20 our $alioth_git = 'git+ssh://$aliothname/$aliothpath';
  21 our $alioth_sshtestbodge = [$aliothname,$aliothpath];
  22
  23 sub mainbranch () { return "$suite"; }
  24 sub uploadingbranch () { return "uploading/$suite"; }
  25
  26 our $ua;
  27
  28 sub url_get {
  29     if (!$ua) {
  30         $ua = LWP::UserAgent->new();
  31         $ua->env_proxy;
  32     }
  33 print DEBUG "fetching @_...\n";
  34     my $r = $ua->get(@_) or die $!;
  35     die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
  36     return $r->decoded_content();
  37 }
  38
  39 our ($dscdata,$dscurl);
  40
  41 sub get_archive_dsc () {
  42     my $pdourl = "$pdo/source/$suite/$package";
  43     my $pdodata = url_get($pdourl);
  44     # FFS.  The Debian archive has no sane way to find what
  45     # version is currently the tip in any branch (aka, what
  46     # is the current version in any suite).
  47     $pdodata =~ m{
  48         Download\ \Q$package\E .*
  49         \<a\ href=\"([^"&]+([^"/]+\.dsc))\"\>\2\</a\>
  50     }msx
  51         or die "screenscraping of $pdourl failed :-(\n";
  52     $dscurl = $1;
  53 print DEBUG Dumper($pdodata, $&, $dscurl);
  54     $dscdata = url_get($dscurl);
  55     my $dscfh = new IO::File \$dscdata, '<' or die $!;
  56 print DEBUG Dumper($dscdata, $dscfh);
  57     my $dscp = Dpkg::Control::Hash->new(allow_pgp=>1);
  58     $dscp->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
  59 #    my $dscf = $dscp->{'fields'};
  60 my $dscf=$dscp;
  61 print DEBUG Dumper($dscp,$dscf);
  62     my $fmt = $dscf->{Format};
  63     die "unsupported format $fmt, sorry\n" unless $fmt eq '1.0';
  64     return $dscf;
  65 }
  66
  67 sub check_for_git () {
  68     # returns 0 or 1
  69     open P, "ssh $alioth_sshtestbodge->[0] '".
  70         "set -e; cd /git/dgit-test;".
  71         "if test -d $package.git; then echo 1; else echo 0; fi".
  72         "' |"
  73         or die $!;
  74     $!=0; $?=0;
  75     my $r = <P>; close P;
  76     die "$r $! $?" unless $r =~ m/^[01]$/;
  77     return !!$r;
  78 }
  79
  80 sub runcmd {
  81     $!=0; $?=0;
  82     die "$! $?" if system @_;
  83 }
  84
  85 our ($dsc,$dsc_hash,$lastupl_hash);
  86
  87 sub generate_commit_from_dsc () {
  88     my $ud = '.git/dgit/unpack';
  89     remove_tree($ud);
  90     mkpath '.git/dgit';
  91     mkdir $ud or die $!;
  92     chdir $ud or die $!;
  93     my @files;
  94     foreach (split /\n/, ($dsch->{Checksums-Sha256} || $dsch->{Files})) {
  95         next unless m/\S/;
  96         m/^\w+ \d+ (\S+)$/ or die "$_ ?";
  97         my $f = $1;
  98         die if $f =~ m#/|^\.|\.dsc$|\.tmp$#;
  99         push @files, $f;
 100         link "../../../$f", $f
 101             or $!==&ENOENT
 102             or die "$f $!";
 103     }
 104     runcmd qw(dget --), $dscurl;
 105     foreach my $f (grep { m/\.tar\.gz$/ } @files) {
 106         link $f, "../../../$f"
 107             or $!==&EEXIST
 108             or die "$f $!";
 109     }
 110     my (@dirs) = <*/.>;
 111     die unless @dirs==1;
 112     $dirs[0] =~ m#^([^/]+)/\.$# or die;
 113     my $dir = $1;
 114     chdir $dir or die "$dir $!";
 115     die if stat '.git';
 116     die $! unless $!==&ENOENT;
 117     runcmd qw(git init);
 118     remove_tree(.git/objects);
 119     symlink '../../objects','.git/objects' or die $!;
 120     runcmd qw(git add -Af);
 121     my $tree = cmdoutput qw(git write-tree);
 122     chomp $tree or die;
 123     runcmd qw(sh -ec), 'dpkg-parsechangelog >../changelog.tmp';
 124     my $clogp = Dpkg::Control::Hash->new();
 125     $clogp->parse('../changelog.tmp','changelog');
 126     my $date = cmdoutput qw(date), '+%s %z', qw(-d),$clogp->{Date};
 127     my $author = $clogp->{Maintainer};
 128     $author =~ s#,.*##ms;
 129     my $authline = "$author $date";
 130     $authline =~ m/^[^<>]+ \<\S+\> \d+ [-+]\d+$/ or die $authline;
 131     open C, ">../commit.tmp" or die $!;
 132     print C "tree $tree\n" or die $!;
 133     print C "parent $lastupl_hash\n" or die $! if defined $lastupl_hash;
 134     print C <<END or die $!;
 135 author $authline
 136 committer $authline
 137
 138 $clogp->{Changes}
 139 # generated by dgit
 140 END
 141     close C or die $!;
 142     my $commithash = runcmd qw(git hash-object -w -t commit ../commit.tmp);
 143     chdir '../../..' or die $!;
 144     remove_tree($ud);
 145     cmdoutput qw(git log -n1), $commithash;
 146     return $commithash;
 147 }
 148
 149 sub fetch_from_archive () {
 150     my $hash;
 151     if (defined $dsc_hash) {
 152         $hash = $dsc_hash;
 153     } else {
 154         $hash = generate_commit_from_dsc();
 155     }
 156     cmdoutput qw(git update-ref FETCH_HEAD) $hash;
 157 }
 158
 159 #sub combine () {
 160 #    if (
 161
 162 #       runcmd qw(git write-tree
 163
 164
 165         runcmd qw(mkdir -p '');
 166 #       chdir '.git/dgit/unpack' or die $!;
 167
 168
 169 #       with_tmpdir($td,{
 170
 171 #    });
 172
 173 #    }
 174
 175 #       open P, "-|", qw(git rev-parse --), $dsc_hash;
 176
 177 #}
 178
 179 sub clone () {
 180     $dsc = get_archive_dsc();
 181     $dsc_hash = $dsc->{'Vcs-git-master'};
 182     if (defined $dsc_hash) {
 183         $dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
 184         $dsc_hash = $&;
 185     }
 186     my $dstdir = "$package";
 187     if (check_for_git()) {
 188         runcmd qw(git clone --origin dgit -b), $suite, '--',
 189             $alioth_git, $dstdir;
 190         chdir "$dstdir" or die "$dstdir $!";
 191         update_from_archive();
 192     } else {
 193         mkdir $dstdir or die "$dstdir $!";
 194         chdir "$dstdir" or die "$dstdir $!";
 195         runcmd qw(git init);
 196         open H, "> .git/refs/HEAD" or die $!;
 197         print H "ref: refs/heads/$suite\n" or die $!;
 198         close H or die $!;
 199         runcmd qw(git remote add dgit), $alioth_git;
 200         runcmd "git config branch.$suite.remote dgit";
 201         runcmd "git config branch.$suite.merge refs/heads/$suite";
 202         update_from_archive();
 203     }
 204 }
 205
 206 sub fetch () {
 207     my ($archive_or_mirror, $suite, $package) = @_;
 208     my $dsc = get_archive_dsc();
 209 }
 210
 211 print Dumper(get_archive_dsc());