lib/Fedora/Rebuild/RPM.pm

   1 package Fedora::Rebuild::RPM;
   2 use strict;
   3 use warnings;
   4 use Moose;
   5 use File::Path;
   6 use RPM2;
   7 use RPM::VersionCompare;
   8 use namespace::clean;
   9
  10 use version 0.77; our $VERSION = version->declare("v0.3.0");
  11
  12 # FLAGS defined in <rpm/rpmds.h> in enum rpmsenseFlags_e:
  13 use constant {
  14     ANY => 0x0,
  15     LESS => 0x2,
  16     GREATER => 0x4,
  17     EQUAL => 0x8
  18 };
  19
  20 # Return string representation of dependency FLAG qualifier (LESS|EQUAL, ...).
  21 # ANY is represented as an asterisk. Higher bits of flag are ignored.
  22 # XXX This is not a method.
  23 sub flag_as_string {
  24     my $flag = $_[0];
  25     my $text = '';
  26
  27     if ($flag & LESS) { $text .= '<'; }
  28     if ($flag & GREATER) { $text .= '>'; }
  29     if ($flag & EQUAL) { $text .= '='; }
  30     if ($text eq '') { $text = '*'; }
  31
  32     return $text;
  33 }
  34
  35 # Add $needles dependecies into $stash dependecies. The $stash will be
  36 # modified. It does not compact overlapping dependencies because provides and
  37 # requires have opposite ordering. It removes identical dependencies only.
  38 # The added dependency is not copied deeply. All references remain unchaged.
  39 # Hash format is { NAME1 => [ [FLAG1, VERSION1], [FLAG2, VERSION2] ] }.
  40 # XXX: This is not a method.
  41 sub adddeps {
  42     my ($stash, $needles) = @_;
  43     for my $needle (keys %{$needles}) {
  44         if (exists $$stash{$needle}) {
  45             my @subneedles = @{$$needles{$needle}};
  46             my @substraws = @{$$stash{$needle}};
  47             NEEDLE: for (my $n = 0; $n <= $#subneedles; $n++) {
  48                 STRAW: for (my $s = 0; $s <= $#substraws; $s++) {
  49                     if ($subneedles[$n][0] eq $substraws[$s][0] &&
  50                         $subneedles[$n][1] eq $substraws[$s][1]) {
  51                         next NEEDLE;
  52                     }
  53                 }
  54                 push @{$$stash{$needle}}, $subneedles[$n];
  55             }
  56         } else  {
  57             $$stash{$needle} = $$needles{$needle};
  58         }
  59     }
  60 }
  61
  62 # Check whether a requires tripplet (name, flag, version) is fulfilled by
  63 # hash of requires. Return true or false (even in parser error).
  64 # Hash format is { NAME1 => [ [FLAG1, VERSION1], [FLAG2, VERSION2] ] }.
  65 # XXX: FLAG cannot contain LESS|GREATER. No implemented.
  66 # XXX: This is not a method.
  67 sub is_satisfied {
  68     my ($rname, $rflag, $rversion, $provides) = @_;
  69
  70     if (! (exists $$provides{$rname})) {
  71         return 0;
  72     }
  73
  74     for my $provide (@{$$provides{$rname}}) {
  75         my $pflag = $$provide[0];
  76         my $pversion = $$provide[1];
  77
  78         if (($rflag & (LESS|GREATER|EQUAL)) == ANY ||
  79             ($pflag & (LESS|GREATER|EQUAL)) == ANY) {
  80             return 1;
  81         }
  82
  83         my $order = RPM::VersionCompare::labelCompare($rversion, $pversion);
  84         if (!defined $order) {
  85             # Parser error;
  86             return 0;
  87         }
  88
  89         # Satisfaction matrix:
  90         #
  91         # (labelCompare($rversion,$pversion) = $order) == 0:
  92         #           pflag
  93         #           <   <=  ==  >=  >
  94         # rflag <   1   1   0   0   0
  95         #       <=  1   1   1   1   0
  96         #       ==  0   1   1   1   0
  97         #       =>  0   1   1   1   1
  98         #       >   0   0   0   1   1
  99         #
 100         if ($order == 0) {
 101             if (($rflag & EQUAL) && ($pflag & EQUAL)) { return 1; }
 102             if (($rflag & LESS) && ($pflag & LESS)) { return 1; }
 103             if (($rflag & GREATER) && ($pflag & GREATER)) { return 1; }
 104         }
 105
 106         # (labelCompare($rversion,$pversion) = $order) > 0:
 107         #           pflag
 108         #           <   <=  ==  >=  >
 109         # rflag <   1   1   1   1   1
 110         #       <=  1   1   1   1   1
 111         #       ==  0   0   0   1   1
 112         #       =>  0   0   0   1   1
 113         #       >   0   0   0   1   1
 114         #
 115         if ($order > 0) {
 116             if (($rflag & LESS) || ($pflag & GREATER)) { return 1; }
 117         }
 118
 119         # (labelCompare($rversion,$pversion) = $order) < 0:
 120         #           pflag
 121         #           <   <=  ==  >=  >
 122         # rflag <   1   1   0   0   0
 123         #       <=  1   1   0   0   0
 124         #       ==  1   1   0   0   0
 125         #       =>  1   1   1   1   1
 126         #       >   1   1   1   1   1
 127         #
 128         if ($order < 0) {
 129             if (($rflag & GREATER) || ($pflag & LESS)) { return 1; }
 130         }
 131     }
 132
 133     return 0;
 134 }
 135
 136
 137 has 'name' => (is => 'ro', isa => 'Str', required => 1);
 138
 139
 140 # Destile provides from local RPM package.
 141 # Return reference to hash of provides or in case of failure, return undef
 142 # and set $@.
 143 # Hash format is { NAME1 => [ [FLAG1, VERSION1], [FLAG2, VERSION2] ] }.
 144 sub provides {
 145     my $self = shift;
 146
 147     my $headers;
 148     if (!eval { $headers = RPM2->open_package($self->name); }) {
 149         $@ = "Could not load RPM package `" . $self->name . "': ". $@;
 150         return undef;
 151     }
 152
 153     my @names = $headers->tag('PROVIDENAME');
 154     my @flags = $headers->tag('PROVIDEFLAGS');
 155     my @versions = $headers->tag('PROVIDEVERSION');
 156     if (!($#names == $#flags) && ($#names == $#versions)) {
 157         $@ = "Inconsistent number of provides names, flags, and versions in `"
 158             . $self->name . "' RPM package";
 159         return undef;
 160     }
 161
 162     my %provides;
 163     while (
 164             my $name = shift @names,
 165             my $flag = shift @flags,
 166             defined(my $version = shift @versions)
 167     ) {
 168         # ???: Filter some higher flag bits?
 169         if (!exists $provides{$name}) { $provides{$name} = []; }
 170         push @{$provides{$name}}, [$flag, $version];
 171     }
 172
 173     return \%provides;
 174 }
 175
 176 # Destile requires from local RPM package.
 177 # Return reference to hash of requires or in case of failure, return undef
 178 # and set $@.
 179 # Hash format is { NAME1 => [ [FLAG1, VERSION1], [FLAG2, VERSION2] ] }.
 180 sub requires {
 181     my $self = shift;
 182
 183     my $headers;
 184     if (!eval { $headers = RPM2->open_package($self->name); }) {
 185         $@ = "Could not load RPM package `" . $self->name . "': ". $@;
 186         return undef;
 187     }
 188
 189     my @names = $headers->tag('REQUIRENAME');
 190     my @flags = $headers->tag('REQUIREFLAGS');
 191     my @versions = $headers->tag('REQUIREVERSION');
 192     if (!($#names == $#flags) && ($#names == $#versions)) {
 193         $@ = "Inconsistent number of requires names, flags, and versions in `"
 194             . $self->name . "' RPM package";
 195         return undef;
 196     }
 197
 198     my %requires;
 199     while (
 200             my $name = shift @names,
 201             my $flag = shift @flags,
 202             defined(my $version = shift @versions)
 203     ) {
 204         # ???: Filter some higher flag bits?
 205         if (!exists $requires{$name}) { $requires{$name} = []; }
 206         push @{$requires{$name}}, [$flag, $version];
 207     }
 208
 209     return \%requires;
 210 }
 211
 212 1;