lib/WB/QD.pm

   1 package WB::QD;
   2
   3 use strict;
   4 use IO::Uncompress::AnyInflate qw(anyinflate);
   5 use Dpkg::Version (); # import nothing
   6 if ( defined $Dpkg::Version::VERSION ) {
   7     *vercmp = \&Dpkg::Version::version_compare;
   8 } else {
   9     *vercmp = \&Dpkg::Version::vercmp;
  10 }
  11 use Dpkg::Arch qw(debarch_is);
  12 use Data::Dumper;
  13
  14 sub readsourcebins {
  15     my $arch = shift;
  16     my $pasfile = shift;
  17     my $SRC = shift;
  18     my $BIN = shift;
  19     my $binary = {};
  20
  21     my $pas = {};
  22     local($/) = "\n";
  23     open(my $pasf, '<', $pasfile);
  24     while(<$pasf>) {
  25         chomp;
  26         s,\s*#.*,,;
  27         next unless $_;
  28         my ($p, $c) = split(/:\s*/);
  29         $pas->{$p} = { arch => [ split(/\s+/, $c) ], mode => substr($c, 0, 1) ne '!' };
  30     }
  31     close $pasf;
  32
  33     my $srcs = {};
  34     local($/) = ""; # read in paragraph mode
  35
  36     foreach my $s (@$SRC) {
  37         my $S = new IO::Uncompress::AnyInflate($s) || return "WB::QD::SRC can't open $s";
  38         while(<$S>) {
  39             my $p={};
  40             /^Package:\s*(\S+)$/mi and $p->{'name'} = $1;
  41             /^Version:\s*(\S+)$/mi and $p->{'version'} = $1;
  42             /^Binary:\s*(.*)$/mi and $p->{'binary'} = $1;
  43             /^Architecture:\s*(.+)$/mi and $p->{'arch'} = $1;
  44             /^Priority:\s*(\S+)$/mi and $p->{'priority'} = $1;
  45             /^Section:\s*(\S+)$/mi and $p->{'section'} = $1;
  46             /^Build-Depends:\s*(.*)$/mi and $p->{'depends'} = $1;
  47             /^Build-Conflicts:\s*(.*)$/mi and $p->{'conflicts'} = $1;
  48
  49             next unless $p->{'name'} and $p->{'version'};
  50             foreach my $tarch (split(/\s+/, $p->{'arch'})) {
  51                 $p->{'for-us'} = 1 if debarch_is($arch, $tarch);
  52                 # Arch: all hackery.
  53                 $p->{'for-us'} = 1 if $tarch eq 'all' and $arch eq 'amd64';
  54             }
  55
  56             # ignore if package already exists with higher version
  57             if ($srcs->{$p->{'name'}}) {
  58                 next if (vercmp($srcs->{$p->{'name'}}->{'version'}, $p->{'version'}) > 0);
  59             }
  60             if ($p->{'binary'}) {
  61                 $p->{'binary'} = [ split(/,? /, $p->{'binary'}) ];
  62             }
  63             $srcs->{$p->{'name'}} = $p;
  64         }
  65         close $S;
  66     }
  67
  68     foreach my $p (@$BIN) {
  69         my $P = new IO::Uncompress::AnyInflate($p) || return "WB::QD::PKGS can't open $p";
  70         while(<$P>) {
  71             my $p;
  72             /^Version:\s*(\S+)$/mi and $p->{'version'} = $1;
  73             /^Version:\s*(\S+)\+b([0-9]+)$/mi and $p->{'version'} = $1 and $p->{'binnmu'} = $2;
  74             /^Architecture:\s*(\S+)$/mi and $p->{'arch'} = $1;
  75             /^Package:\s*(\S+)$/mi and $p->{'binary'} = $1;
  76             /^Package:\s*(\S+)$/mi and $p->{'source'} = $1;
  77             /^Source:\s*(\S+)$/mi and $p->{'source'} = $1;
  78             /^Source:\s*(\S+)\s+\((\S+)\)$/mi and $p->{'source'} = $1 and $p->{'version'} = $2;
  79
  80             # consider packages as non-existant if it's all but outdated
  81             # arch:all and ver(binary) < ver(source) => skip
  82             next if $p->{'arch'} eq 'all' && $srcs->{$p->{'source'}} && $srcs->{$p->{'source'}}->{'version'} && vercmp($srcs->{$p->{'source'}}->{'version'}, $p->{'version'}) > 0;
  83             # not for the current architecture or arch:all => skip
  84             next unless $p->{'arch'} eq 'all' || $p->{'arch'} eq ${arch};
  85             # register the binary if there isn't a newer one in the hash yet
  86             $binary->{$p->{'binary'}} = { 'version' => $p->{'version'}, 'arch' => $p->{'arch'}}
  87                 unless $binary->{$p->{'binary'}} and vercmp($binary->{$p->{'binary'}}->{'version'}, $p->{'version'}) < 0;
  88
  89             #next if $pas->{$p->{'binary'}} && pasignore($pas->{$p->{'binary'}}, $arch);
  90
  91             # only continue if it's arch-specific...
  92             # Arch: all hackery.
  93             next if $p->{'arch'} eq 'all' and $arch ne 'amd64';
  94
  95             # annotate the source package if present, continue otherwise
  96             next unless $srcs->{$p->{'source'}};
  97
  98             $srcs->{$p->{'source'}}->{'compiled'} = 1;
  99
 100             # TODO: ???
 101             next unless $srcs->{$p->{'source'}}->{'version'} eq $p->{'version'};
 102             $srcs->{$p->{'source'}}->{'installed'} = 1;
 103
 104             next unless $p->{'binnmu'};
 105             next if ($srcs->{$p->{'source'}}->{'binnmu'}) && ($srcs->{$p->{'source'}}->{'binnmu'} > $p->{'binnmu'});
 106             $srcs->{$p->{'source'}}->{'binnmu'} = $p->{'binnmu'};
 107         }
 108         close $P;
 109     }
 110
 111     SRCS:
 112     for my $k (keys %$srcs) {
 113 #       if ($k eq 'r-bioc-abarray') {
 114 #       use Data::Dumper;
 115 #       print STDERR Dumper($srcs->{$k})
 116 #       }
 117         if ($srcs->{$k}->{'installed'}) {
 118             $srcs->{$k}->{'status'} = 'installed';
 119             delete $srcs->{$k}->{'installed'};
 120         } elsif ($srcs->{$k}->{'compiled'}) {
 121             $srcs->{$k}->{'status'} = 'out-of-date';
 122         } else {
 123             $srcs->{$k}->{'status'} = 'uncompiled';
 124         }
 125         delete $srcs->{$k}->{'compiled'};
 126         # $srcs->{$k}->{'status'} = 'installed' if $srcs->{$k}->{'arch'} && $srcs->{$k}->{'arch'} eq 'all';
 127
 128         if (!$srcs->{$k}->{'for-us'} && $srcs->{$k}->{'status'} ne 'installed') {
 129             $srcs->{$k}->{'status'} = 'arch-not-in-arch-list';
 130         }
 131         delete $srcs->{$k}->{'for-us'};
 132
 133 #       if ($k eq 'r-bioc-abarray') {
 134 #       use Data::Dumper;
 135 #       print STDERR Dumper($srcs->{$k})
 136 #       }
 137 #         if ($srcs->{$k}->{'arch'} eq 'all') {
 138 #             $srcs->{$k}->{'status'} = 'arch-all-only';
 139 #             delete $srcs->{$k}->{'arch'};
 140 #             next;
 141 #         }
 142         delete $srcs->{$k}->{'arch'};
 143
 144         if (pasignore($pas->{'%'.$k}, $arch)) {
 145             $srcs->{$k}->{'status'} = 'packages-arch-specific';
 146             next;
 147         }
 148         for my $bin (@{$srcs->{$k}->{'binary'}}) {
 149             $srcs->{$k}->{'pas'} = 1 if pasignore($pas->{$bin}, $arch);
 150             next if pasignore($pas->{$bin}, $arch);
 151             next if $binary->{$bin} and $binary->{$bin}->{'arch'} eq 'all';
 152             next SRCS;
 153         }
 154         if ($srcs->{$k}->{'pas'}) {
 155             $srcs->{$k}->{'status'} = 'packages-arch-specific';
 156         } else {
 157             $srcs->{$k}->{'status'} = 'overwritten-by-arch-all';
 158         }
 159         delete $srcs->{$k}->{'pas'};
 160     }
 161     $srcs->{'_binary'} = $binary;
 162     local($/) = "\n";
 163
 164     return \$srcs;
 165 }
 166
 167 sub pasignore {
 168     my $p = shift;
 169     my $arch = shift;
 170     if ($p && $p->{'mode'}) {
 171         return 1 unless grep { $_ eq $arch } @{$p->{'arch'}};
 172     }
 173     if ($p && not $p->{'mode'}) {
 174         return 1 if grep /^!$arch$/, @{$p->{'arch'}};
 175     }
 176     return 0;
 177 }
 178
 179 1;