lib/WB/QD.pm

   1 package WB::QD;
   2
   3 use strict;
   4 use IO::Uncompress::AnyInflate qw(anyinflate);
   5 use Dpkg::Version qw(vercmp);
   6 use Dpkg::Arch qw(debarch_is);
   7 use Data::Dumper;
   8
   9 sub readsourcebins {
  10     my $arch = shift;
  11     my $pasfile = shift;
  12     my $SRC = shift;
  13     my $BIN = shift;
  14     my $binary = {};
  15
  16     my $pas = {};
  17     local($/) = "\n";
  18     open(my $pasf, '<', $pasfile);
  19     while(<$pasf>) {
  20         chomp;
  21         s,\s*#.*,,;
  22         next unless $_;
  23         my ($p, $c) = split(/:\s*/);
  24         $pas->{$p} = { arch => [ split(/\s+/, $c) ], mode => substr($c, 0, 1) ne '!' };
  25     }
  26     close $pasf;
  27
  28     my $srcs = {};
  29     local($/) = ""; # read in paragraph mode
  30
  31     foreach my $s (@$SRC) {
  32         my $S = new IO::Uncompress::AnyInflate($s) || return "WB::QD::SRC can't open $s";
  33         while(<$S>) {
  34             my $p={};
  35             /^Package:\s*(\S+)$/mi and $p->{'name'} = $1;
  36             /^Version:\s*(\S+)$/mi and $p->{'version'} = $1;
  37             /^Binary:\s*(.*)$/mi and $p->{'binary'} = $1;
  38             /^Architecture:\s*(.+)$/mi and $p->{'arch'} = $1;
  39             /^Priority:\s*(\S+)$/mi and $p->{'priority'} = $1;
  40             /^Section:\s*(\S+)$/mi and $p->{'section'} = $1;
  41             /^Build-Depends:\s*(.*)$/mi and $p->{'depends'} = $1;
  42             /^Build-Conflicts:\s*(.*)$/mi and $p->{'conflicts'} = $1;
  43
  44             next unless $p->{'name'} and $p->{'version'};
  45             next if $p->{'arch'} eq 'all';
  46             foreach my $tarch (split(/\s+/, $p->{'arch'})) {
  47                 $p->{'for-us'} = 1 if debarch_is($arch, $tarch);
  48             }
  49             delete $p->{'arch'};
  50
  51             # ignore if package already exists with higher version
  52             if ($srcs->{$p->{'name'}}) {
  53                 next if (vercmp($srcs->{$p->{'name'}}->{'version'}, $p->{'version'}) > 0);
  54             }
  55             if ($p->{'binary'}) {
  56                 $p->{'binary'} = [ split(/,? /, $p->{'binary'}) ];
  57             }
  58             $srcs->{$p->{'name'}} = $p;
  59         }
  60         close $S;
  61     }
  62
  63     foreach my $p (@$BIN) {
  64         my $P = new IO::Uncompress::AnyInflate($p) || return "WB::QD::PKGS can't open $p";
  65         while(<$P>) {
  66             my $p;
  67             /^Version:\s*(\S+)$/mi and $p->{'version'} = $1;
  68             /^Version:\s*(\S+)\+b([0-9]+)$/mi and $p->{'version'} = $1 and $p->{'binnmu'} = $2;
  69             /^Architecture:\s*(\S+)$/mi and $p->{'arch'} = $1;
  70             /^Package:\s*(\S+)$/mi and $p->{'binary'} = $1;
  71             /^Package:\s*(\S+)$/mi and $p->{'source'} = $1;
  72             /^Source:\s*(\S+)$/mi and $p->{'source'} = $1;
  73             /^Source:\s*(\S+)\s+\((\S+)\)$/mi and $p->{'source'} = $1 and $p->{'version'} = $2;
  74
  75             next unless $p->{'arch'} eq 'all' || $p->{'arch'} eq ${arch};
  76             $binary->{$p->{'binary'}} = { 'version' => $p->{'version'}, 'arch' => $p->{'arch'}} unless $binary->{$p->{'binary'}} and vercmp($binary->{$p->{'binary'}}->{'version'}, $p->{'version'}) < 0;
  77
  78             #next if $pas->{$p->{'binary'}} && pasignore($pas->{$p->{'binary'}}, $arch);
  79             next if $p->{'arch'} eq 'all';
  80             next unless $srcs->{$p->{'source'}};
  81             $srcs->{$p->{'source'}}->{'compiled'} = 1;
  82             next unless $srcs->{$p->{'source'}}->{'version'} eq $p->{'version'};
  83             $srcs->{$p->{'source'}}->{'installed'} = 1;
  84             next unless $p->{'binnmu'};
  85             next if ($srcs->{$p->{'source'}}->{'binnmu'}) && ($srcs->{$p->{'source'}}->{'binnmu'} > $p->{'binnmu'});
  86             $srcs->{$p->{'source'}}->{'binnmu'} = $p->{'binnmu'};
  87         }
  88         close $P;
  89     }
  90
  91     SRCS:
  92     for my $k (keys %$srcs) {
  93         if ($srcs->{$k}->{'installed'}) {
  94             $srcs->{$k}->{'status'} = 'installed';
  95             delete $srcs->{$k}->{'installed'};
  96         } elsif ($srcs->{$k}->{'compiled'}) {
  97             $srcs->{$k}->{'status'} = 'out-of-date';
  98         } else {
  99             $srcs->{$k}->{'status'} = 'uncompiled';
 100         }
 101         delete $srcs->{$k}->{'compiled'};
 102         $srcs->{$k}->{'status'} = 'installed' if $srcs->{$k}->{'arch'} && $srcs->{$k}->{'arch'} eq 'all';
 103
 104         if (!$srcs->{$k}->{'for-us'} && $srcs->{$k}->{'status'} ne 'installed') {
 105             $srcs->{$k}->{'status'} = 'auto-not-for-us';
 106         }
 107         delete $srcs->{$k}->{'for-us'};
 108
 109         #my $p = $pas->{$k};
 110         #$p ||= $pas->{'%'.$k};
 111         #$srcs->{$k}->{'status'} = 'not-for-us' if pasignore($p, $arch);
 112         if (pasignore($pas->{'%'.$k}, $arch)) {
 113             $srcs->{$k}->{'status'} = 'not-for-us';
 114             next;
 115         }
 116         for my $bin (@{$srcs->{$k}->{'binary'}}) {
 117             next if pasignore($pas->{$bin}, $arch);
 118             next if $binary->{$bin} and $binary->{$bin}->{'arch'} eq 'all';
 119             next SRCS;
 120         }
 121         $srcs->{$k}->{'status'} = 'not-for-us';
 122     }
 123     $srcs->{'_binary'} = $binary;
 124     local($/) = "\n";
 125
 126     return \$srcs;
 127 }
 128
 129 sub pasignore {
 130     my $p = shift;
 131     my $arch = shift;
 132     if ($p && $p->{'mode'}) {
 133         return 1 unless grep { $_ eq $arch } @{$p->{'arch'}};
 134     }
 135     if ($p && not $p->{'mode'}) {
 136         return 1 if grep /^!$arch$/, @{$p->{'arch'}};
 137     }
 138     return 0;
 139 }
 140
 141 1;