Build/Arch.pm

   1 package Build::Arch;
   2
   3 use strict;
   4 use Digest::MD5;
   5
   6 eval { require Archive::Tar; };
   7 *Archive::Tar::new = sub {die("Archive::Tar is not available\n")} unless defined &Archive::Tar::new;
   8
   9
  10 # Archlinux support, based on the GSoC work of Nikolay Rysev <mad.f3ka@gmail.com>
  11
  12 # parse a PKGBUILD file
  13
  14 sub quote {
  15   my ($str) = @_;
  16   $str =~ s/([ \t\"\'])/sprintf("%%%02X", ord($1))/ge;
  17   return $str;
  18 }
  19
  20 sub unquotesplit {
  21   my ($str) = @_;
  22   $str =~ s/%/%25/g;
  23   $str =~ s/^[ \t]+//;
  24   while ($str =~ /([\"\'])/) {
  25     my $q = $1;
  26     $str =~ s/$q(.*?)$q/quote($1)/e;
  27   }
  28   my @args = split(/[ \t]+/, $str);
  29   for (@args) {
  30     s/%([a-fA-F0-9]{2})/chr(hex($1))/ge
  31   }
  32   return @args;
  33 }
  34
  35 sub parse {
  36   my ($config, $pkgbuild) = @_;
  37   my $ret;
  38   local *PKG;
  39   if (!open(PKG, '<', $pkgbuild)) {
  40     $ret->{'error'} = "$pkgbuild: $!";
  41     return $ret;
  42   }
  43   my %vars;
  44   while (<PKG>) {
  45     chomp;
  46     next if /^\s*$/;
  47     next if /^\s*#/;
  48     last unless /^([a-zA-Z0-9_]*)=(\(?)(.*?)$/;
  49     my $var = $1;
  50     my $val = $3;
  51     if ($2) {
  52       while ($val !~ s/\)\s*$//s) {
  53         my $nextline = <PKG>;
  54         last unless defined $nextline;
  55         chomp $nextline;
  56         $val .= ' ' . $nextline;
  57       }
  58     }
  59     $vars{$var} = [ unquotesplit($val) ];
  60   }
  61   close PKG;
  62   $ret->{'name'} = $vars{'pkgname'}->[0] if $vars{'pkgname'};
  63   $ret->{'version'} = $vars{'pkgver'}->[0] if $vars{'pkgver'};
  64   $ret->{'deps'} = $vars{'makedepends'} || [];
  65   return $ret;
  66 }
  67
  68 sub islzma {
  69   my ($fn) = @_;
  70   local *F;
  71   return 0 unless open(F, '<', $fn);
  72   my $h;
  73   return 0 unless read(F, $h, 5) == 5;
  74   close F;
  75   return $h eq "\3757zXZ";
  76 }
  77
  78 sub lzmadec {
  79   my ($fn) = @_;
  80   my $nh;
  81   my $pid = open($nh, '-|');
  82   return undef unless defined $pid;
  83   if (!$pid) {
  84     $SIG{'PIPE'} = 'DEFAULT';
  85     exec('xzdec', '-dc', $fn);
  86     die("xzdec: $!\n");
  87   }
  88   return $nh;
  89 }
  90
  91 sub queryvars {
  92   my ($handle) = @_;
  93
  94   if (ref($handle)) {
  95     die("arch pkg query not implemented for file handles\n");
  96   }
  97   if ($handle =~ /\.xz$/ || islzma($handle)) {
  98     $handle = lzmadec($handle);
  99   }
 100   my $tar = Archive::Tar->new;
 101   my @read = $tar->read($handle, 1, {'filter' => '^\.PKGINFO$', 'limit' => 1});
 102   die("$handle: not an arch package file\n") unless @read ==  1;
 103   my $pkginfo = $read[0]->get_content;
 104   die("$handle: not an arch package file\n") unless $pkginfo;
 105   my %vars;
 106   $vars{'_pkginfo'} = $pkginfo;
 107   for my $l (split('\n', $pkginfo)) {
 108     next unless $l =~ /^(.*?) = (.*)$/;
 109     push @{$vars{$1}}, $2;
 110   }
 111   return \%vars;
 112 }
 113
 114 sub queryfiles {
 115   my ($handle) = @_;
 116   if (ref($handle)) {
 117     die("arch pkg query not implemented for file handles\n");
 118   }
 119   if ($handle =~ /\.xz$/ || islzma($handle)) {
 120     $handle = lzmadec($handle);
 121   }
 122   my @files;
 123   my $tar = Archive::Tar->new;
 124   # we use filter_cb here so that Archive::Tar skips the file contents
 125   $tar->read($handle, 1, {'filter_cb' => sub {
 126     my ($entry) = @_;
 127     push @files, $entry->name unless $entry->is_longlink || (@files && $files[-1] eq $entry->name);
 128     return 0;
 129   }});
 130   shift @files if @files && $files[0] eq '.PKGINFO';
 131   return \@files;
 132 }
 133
 134 sub query {
 135   my ($handle, %opts) = @_;
 136   my $vars = queryvars($handle);
 137   my $ret = {};
 138   $ret->{'name'} = $vars->{'pkgname'}->[0] if $vars->{'pkgname'};
 139   $ret->{'hdrmd5'} = Digest::MD5::md5_hex($vars->{'_pkginfo'});
 140   $ret->{'provides'} = $vars->{'provides'} || [];
 141   $ret->{'requires'} = $vars->{'depend'} || [];
 142   if ($vars->{'pkgname'}) {
 143     my $selfprovides = $vars->{'pkgname'}->[0];
 144     $selfprovides .= "=$vars->{'pkgver'}->[0]" if $vars->{'pkgver'};
 145     push @{$ret->{'provides'}}, $selfprovides unless @{$ret->{'provides'} || []} && $ret->{'provides'}->[-1] eq $selfprovides;
 146   }
 147   if ($opts{'evra'}) {
 148     if ($vars->{'pkgver'}) {
 149       my $evr = $vars->{'pkgver'}->[0];
 150       if ($evr =~ /^([0-9]+):(.*)$/) {
 151         $ret->{'epoch'} = $1;
 152         $evr = $2;
 153       }
 154       $ret->{'version'} = $evr;
 155       if ($evr =~ /^(.*)-(.*?)$/) {
 156         $ret->{'version'} = $1;
 157         $ret->{'release'} = $2;
 158       }
 159     }
 160     $ret->{'arch'} = $vars->{'arch'}->[0] if $vars->{'arch'};
 161   }
 162   if ($opts{'description'}) {
 163     $ret->{'description'} = $vars->{'pkgdesc'}->[0] if $vars->{'pkgdesc'};
 164   }
 165   # arch packages don't seem to have a source :(
 166   # fake it so that the package isn't confused with a src package
 167   $ret->{'source'} = $ret->{'name'} if defined $ret->{'name'};
 168   return $ret;
 169 }
 170
 171 sub queryhdrmd5 {
 172   my ($handle) = @_;
 173   if (ref($handle)) {
 174     die("arch pkg query not implemented for file handles\n");
 175   }
 176   if ($handle =~ /\.xz$/ || islzma($handle)) {
 177     $handle = lzmadec($handle);
 178   }
 179   my $tar = Archive::Tar->new;
 180   my @read = $tar->read($handle, 1, {'filter' => '^\.PKGINFO$', 'limit' => 1});
 181   die("$handle: not an arch package file\n") unless @read ==  1;
 182   my $pkginfo = $read[0]->get_content;
 183   die("$handle: not an arch package file\n") unless $pkginfo;
 184   return Digest::MD5::md5_hex($pkginfo);
 185 }
 186
 187 sub parserepodata {
 188   my ($d, $data) = @_;
 189   $d ||= {};
 190   $data =~ s/^\n+//s;
 191   my @parts = split(/\n\n+/s, $data);
 192   for my $part (@parts) {
 193     my @p = split("\n", $part);
 194     my $p = shift @p;
 195     if ($p eq '%NAME%') {
 196       $d->{'name'} = $p[0];
 197     } elsif ($p eq '%VERSION%') {
 198       $d->{'version'} = $p[0];
 199     } elsif ($p eq '%ARCH%') {
 200       $d->{'arch'} = $p[0];
 201     } elsif ($p eq '%BUILDDATE%') {
 202       $d->{'buildtime'} = $p[0];
 203     } elsif ($p eq '%FILENAME%') {
 204       $d->{'filename'} = $p[0];
 205     } elsif ($p eq '%PROVIDES%') {
 206       push @{$d->{'provides'}}, @p;
 207     } elsif ($p eq '%DEPENDS%') {
 208       push @{$d->{'requires'}}, @p;
 209     }
 210   }
 211   return $d;
 212 }
 213
 214 1;