Fix build-priority setting
[mirror/wanna-build.git] / 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             if ($arch eq 'all') {
51                 $p->{'for-us'} = 1 if $arch =~ $p->{'arch'};
52             } else{
53                 foreach my $tarch (split(/\s+/, $p->{'arch'})) {
54                     $p->{'for-us'} = 1 if debarch_is($arch, $tarch);
55                 }
56             }
57
58             # ignore if package already exists with higher version
59             if ($srcs->{$p->{'name'}}) {
60                 next if (vercmp($srcs->{$p->{'name'}}->{'version'}, $p->{'version'}) > 0);
61             }
62             if ($p->{'binary'}) {
63                 $p->{'binary'} = [ split(/,? /, $p->{'binary'}) ];
64             }
65             $srcs->{$p->{'name'}} = $p;
66         }
67         close $S;
68     }
69
70     foreach my $p (@$BIN) {
71         my $P = new IO::Uncompress::AnyInflate($p) || return "WB::QD::PKGS can't open $p";
72         while(<$P>) {
73             my $p;
74             /^Version:\s*(\S+)$/mi and $p->{'version'} = $1;
75             /^Version:\s*(\S+)\+b([0-9]+)$/mi and $p->{'version'} = $1 and $p->{'binnmu'} = $2;
76             /^Architecture:\s*(\S+)$/mi and $p->{'arch'} = $1;
77             /^Package:\s*(\S+)$/mi and $p->{'binary'} = $1;
78             /^Package:\s*(\S+)$/mi and $p->{'source'} = $1;
79             /^Source:\s*(\S+)$/mi and $p->{'source'} = $1;
80             /^Source:\s*(\S+)\s+\((\S+)\)$/mi and $p->{'source'} = $1 and $p->{'version'} = $2;
81
82             if ($arch ne 'all') {
83                 # consider packages as non-existant if it's all but outdated
84                 # arch:all and ver(binary) < ver(source) => skip
85                 next if $p->{'arch'} eq 'all' && $srcs->{$p->{'source'}} && $srcs->{$p->{'source'}}->{'version'} && vercmp($srcs->{$p->{'source'}}->{'version'}, $p->{'version'}) > 0;
86                 # not for the current architecture or arch:all => skip
87                 next unless $p->{'arch'} eq 'all' || $p->{'arch'} eq ${arch};
88             }
89             # register the binary if there isn't a newer one in the hash yet
90             $binary->{$p->{'binary'}} = { 'version' => $p->{'version'}, 'arch' => $p->{'arch'}}
91                 unless $binary->{$p->{'binary'}} and vercmp($binary->{$p->{'binary'}}->{'version'}, $p->{'version'}) < 0;
92
93             #next if $pas->{$p->{'binary'}} && pasignore($pas->{$p->{'binary'}}, $arch);
94
95             # only continue if it's arch-specific...
96             next if ($arch ne 'all') && ($p->{'arch'} eq 'all');
97             next if ($arch eq 'all') && ($p->{'arch'} !~ /all/);
98
99             # annotate the source package if present, continue otherwise
100             next unless $srcs->{$p->{'source'}};
101
102             $srcs->{$p->{'source'}}->{'compiled'} = 1;
103
104             # TODO: ???
105             next unless $srcs->{$p->{'source'}}->{'version'} eq $p->{'version'};
106             $srcs->{$p->{'source'}}->{'installed'} = 1;
107
108             next unless $p->{'binnmu'};
109             next if ($srcs->{$p->{'source'}}->{'binnmu'}) && ($srcs->{$p->{'source'}}->{'binnmu'} > $p->{'binnmu'});
110             $srcs->{$p->{'source'}}->{'binnmu'} = $p->{'binnmu'};
111         }
112         close $P;
113     }
114
115     SRCS:
116     for my $k (keys %$srcs) {
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' and $arch ne '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 ($srcs->{$k}->{'arch'} eq 'all' and $arch ne 'all') {
134             $srcs->{$k}->{'status'} = 'arch-all-only';
135             delete $srcs->{$k}->{'arch'};
136             next;
137         }
138         delete $srcs->{$k}->{'arch'};
139         
140         if (pasignore($pas->{'%'.$k}, $arch)) {
141             $srcs->{$k}->{'status'} = 'packages-arch-specific';
142             next;
143         }
144         for my $bin (@{$srcs->{$k}->{'binary'}}) {
145             $srcs->{$k}->{'pas'} = 1 if pasignore($pas->{$bin}, $arch);
146             next if pasignore($pas->{$bin}, $arch);
147             next if $binary->{$bin} and $binary->{$bin}->{'arch'} eq 'all' and $arch ne 'all';
148             next SRCS;
149         }
150         if ($srcs->{$k}->{'pas'}) {
151             $srcs->{$k}->{'status'} = 'packages-arch-specific';
152         } else {
153             $srcs->{$k}->{'status'} = 'overwritten-by-arch-all';
154         }
155         delete $srcs->{$k}->{'pas'};
156     }
157     $srcs->{'_binary'} = $binary;
158     local($/) = "\n";
159
160     return \$srcs;
161 }
162
163 sub pasignore {
164     my $p = shift;
165     my $arch = shift;
166     if ($p && $p->{'mode'}) {
167         return 1 unless grep { $_ eq $arch } @{$p->{'arch'}};
168     }
169     if ($p && not $p->{'mode'}) {
170         return 1 if grep /^!$arch$/, @{$p->{'arch'}};
171     }
172     return 0;
173 }
174
175 1;