lib/Fedora/Rebuild/RPM.pm

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