Commit | Line | Data |
---|---|---|
1479465f GJ |
1 | # Copyright © 2009 Raphaël Hertzog <hertzog@debian.org> |
2 | # | |
3 | # This program is free software; you can redistribute it and/or modify | |
4 | # it under the terms of the GNU General Public License as published by | |
5 | # the Free Software Foundation; either version 2 of the License, or | |
6 | # (at your option) any later version. | |
7 | # | |
8 | # This program is distributed in the hope that it will be useful, | |
9 | # but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
11 | # GNU General Public License for more details. | |
12 | # | |
13 | # You should have received a copy of the GNU General Public License | |
14 | # along with this program. If not, see <https://www.gnu.org/licenses/>. | |
15 | ||
16 | package Dpkg::Index; | |
17 | ||
18 | use strict; | |
19 | use warnings; | |
20 | ||
21 | our $VERSION = '1.00'; | |
22 | ||
23 | use Dpkg::Gettext; | |
24 | use Dpkg::ErrorHandling; | |
25 | use Dpkg::Control; | |
26 | ||
27 | use parent qw(Dpkg::Interface::Storable); | |
28 | ||
29 | use overload | |
30 | '@{}' => sub { return $_[0]->{order} }, | |
31 | fallback => 1; | |
32 | ||
33 | =encoding utf8 | |
34 | ||
35 | =head1 NAME | |
36 | ||
37 | Dpkg::Index - generic index of control information | |
38 | ||
39 | =head1 DESCRIPTION | |
40 | ||
41 | This object represent a set of Dpkg::Control objects. | |
42 | ||
43 | =head1 METHODS | |
44 | ||
45 | =over 4 | |
46 | ||
47 | =item $index = Dpkg::Index->new(%opts) | |
48 | ||
49 | Creates a new empty index. See set_options() for more details. | |
50 | ||
51 | =cut | |
52 | ||
53 | sub new { | |
54 | my ($this, %opts) = @_; | |
55 | my $class = ref($this) || $this; | |
56 | ||
57 | my $self = { | |
58 | items => {}, | |
59 | order => [], | |
60 | get_key_func => sub { return $_[0]->{Package} }, | |
61 | type => CTRL_UNKNOWN, | |
62 | }; | |
63 | bless $self, $class; | |
64 | $self->set_options(%opts); | |
65 | if (exists $opts{load}) { | |
66 | $self->load($opts{load}); | |
67 | } | |
68 | ||
69 | return $self; | |
70 | } | |
71 | ||
72 | =item $index->set_options(%opts) | |
73 | ||
74 | The "type" option is checked first to define default values for other | |
75 | options. Here are the relevant options: "get_key_func" is a function | |
76 | returning a key for the item passed in parameters. The index can only | |
77 | contain one item with a given key. The function used depends on the | |
78 | type: for CTRL_INFO_PKG, CTRL_INDEX_SRC, CTRL_INDEX_PKG and CTRL_PKG_DEB | |
79 | it's simply the Package field; for CTRL_PKG_SRC and CTRL_INFO_SRC, it's | |
80 | the Source field; for CTRL_CHANGELOG it's the Source and the Version | |
81 | fields (concatenated with an intermediary "_"); for CTRL_TESTS is either | |
82 | the Tests or Test-Command fields; for CTRL_FILE_CHANGES it's | |
83 | the Source, Version and Architecture fields (concatenated with "_"); | |
84 | for CTRL_FILE_VENDOR it's the Vendor field; for CTRL_FILE_STATUS it's the | |
85 | Package and Architecture fields (concatenated with "_"). Otherwise it's | |
86 | the Package field by default. | |
87 | ||
88 | =cut | |
89 | ||
90 | sub set_options { | |
91 | my ($self, %opts) = @_; | |
92 | ||
93 | # Default values based on type | |
94 | if (exists $opts{type}) { | |
95 | my $t = $opts{type}; | |
96 | if ($t == CTRL_INFO_PKG or $t == CTRL_INDEX_SRC or | |
97 | $t == CTRL_INDEX_PKG or $t == CTRL_PKG_DEB) { | |
98 | $self->{get_key_func} = sub { return $_[0]->{Package}; }; | |
99 | } elsif ($t == CTRL_PKG_SRC or $t == CTRL_INFO_SRC) { | |
100 | $self->{get_key_func} = sub { return $_[0]->{Source}; }; | |
101 | } elsif ($t == CTRL_CHANGELOG) { | |
102 | $self->{get_key_func} = sub { | |
103 | return $_[0]->{Source} . '_' . $_[0]->{Version}; | |
104 | }; | |
105 | } elsif ($t == CTRL_COPYRIGHT_HEADER) { | |
106 | # This is a bit pointless, because the value will almost always | |
107 | # be the same, but guarantees that we use a known field. | |
108 | $self->{get_key_func} = sub { return $_[0]->{Format}; }; | |
109 | } elsif ($t == CTRL_COPYRIGHT_FILES) { | |
110 | $self->{get_key_func} = sub { return $_[0]->{Files}; }; | |
111 | } elsif ($t == CTRL_COPYRIGHT_LICENSE) { | |
112 | $self->{get_key_func} = sub { return $_[0]->{License}; }; | |
113 | } elsif ($t == CTRL_TESTS) { | |
114 | $self->{get_key_func} = sub { | |
115 | return $_[0]->{Tests} || $_[0]->{'Test-Command'}; | |
116 | }; | |
117 | } elsif ($t == CTRL_FILE_CHANGES) { | |
118 | $self->{get_key_func} = sub { | |
119 | return $_[0]->{Source} . '_' . $_[0]->{Version} . '_' . | |
120 | $_[0]->{Architecture}; | |
121 | }; | |
122 | } elsif ($t == CTRL_FILE_VENDOR) { | |
123 | $self->{get_key_func} = sub { return $_[0]->{Vendor}; }; | |
124 | } elsif ($t == CTRL_FILE_STATUS) { | |
125 | $self->{get_key_func} = sub { | |
126 | return $_[0]->{Package} . '_' . $_[0]->{Architecture}; | |
127 | }; | |
128 | } | |
129 | } | |
130 | ||
131 | # Options set by the user override default values | |
132 | $self->{$_} = $opts{$_} foreach keys %opts; | |
133 | } | |
134 | ||
135 | =item $index->get_type() | |
136 | ||
137 | Returns the type of control information stored. See the type parameter | |
138 | set during new(). | |
139 | ||
140 | =cut | |
141 | ||
142 | sub get_type { | |
143 | my $self = shift; | |
144 | return $self->{type}; | |
145 | } | |
146 | ||
147 | =item $index->add($item, [$key]) | |
148 | ||
149 | Add a new item in the index. If the $key parameter is omitted, the key | |
150 | will be generated with the get_key_func function (see set_options() for | |
151 | details). | |
152 | ||
153 | =cut | |
154 | ||
155 | sub add { | |
156 | my ($self, $item, $key) = @_; | |
157 | ||
158 | $key //= $self->{get_key_func}($item); | |
159 | if (not exists $self->{items}{$key}) { | |
160 | push @{$self->{order}}, $key; | |
161 | } | |
162 | $self->{items}{$key} = $item; | |
163 | } | |
164 | ||
165 | =item $index->load($file) | |
166 | ||
167 | Reads the file and creates all items parsed. Returns the number of items | |
168 | parsed. Handles compressed files transparently based on their extensions. | |
169 | ||
170 | =item $index->parse($fh, $desc) | |
171 | ||
172 | Reads the filehandle and creates all items parsed. When called multiple | |
173 | times, the parsed stanzas are accumulated. | |
174 | ||
175 | Returns the number of items parsed. | |
176 | ||
177 | =cut | |
178 | ||
179 | sub parse { | |
180 | my ($self, $fh, $desc) = @_; | |
181 | my $item = $self->new_item(); | |
182 | my $i = 0; | |
183 | while ($item->parse($fh, $desc)) { | |
184 | $self->add($item); | |
185 | $item = $self->new_item(); | |
186 | $i++; | |
187 | } | |
188 | return $i; | |
189 | } | |
190 | ||
191 | =item $index->save($file) | |
192 | ||
193 | Writes the content of the index in a file. Auto-compresses files | |
194 | based on their extensions. | |
195 | ||
196 | =item $item = $index->new_item() | |
197 | ||
198 | Creates a new item. Mainly useful for derived objects that would want | |
199 | to override this method to return something else than a Dpkg::Control | |
200 | object. | |
201 | ||
202 | =cut | |
203 | ||
204 | sub new_item { | |
205 | my $self = shift; | |
206 | return Dpkg::Control->new(type => $self->{type}); | |
207 | } | |
208 | ||
209 | =item $item = $index->get_by_key($key) | |
210 | ||
211 | Returns the item identified by $key or undef. | |
212 | ||
213 | =cut | |
214 | ||
215 | sub get_by_key { | |
216 | my ($self, $key) = @_; | |
217 | return $self->{items}{$key} if exists $self->{items}{$key}; | |
218 | return; | |
219 | } | |
220 | ||
221 | =item @keys = $index->get_keys(%criteria) | |
222 | ||
223 | Returns the keys of items that matches all the criteria. The key of the | |
224 | %criteria hash is a field name and the value is either a regex that needs | |
225 | to match the field value, or a reference to a function that must return | |
226 | true and that receives the field value as single parameter, or a scalar | |
227 | that must be equal to the field value. | |
228 | ||
229 | =cut | |
230 | ||
231 | sub get_keys { | |
232 | my ($self, %crit) = @_; | |
233 | my @selected = @{$self->{order}}; | |
234 | foreach my $s_crit (keys %crit) { # search criteria | |
235 | if (ref($crit{$s_crit}) eq 'Regexp') { | |
236 | @selected = grep { | |
237 | exists $self->{items}{$_}{$s_crit} and | |
238 | $self->{items}{$_}{$s_crit} =~ $crit{$s_crit} | |
239 | } @selected; | |
240 | } elsif (ref($crit{$s_crit}) eq 'CODE') { | |
241 | @selected = grep { | |
242 | &{$crit{$s_crit}}($self->{items}{$_}{$s_crit}); | |
243 | } @selected; | |
244 | } else { | |
245 | @selected = grep { | |
246 | exists $self->{items}{$_}{$s_crit} and | |
247 | $self->{items}{$_}{$s_crit} eq $crit{$s_crit} | |
248 | } @selected; | |
249 | } | |
250 | } | |
251 | return @selected; | |
252 | } | |
253 | ||
254 | =item @items = $index->get(%criteria) | |
255 | ||
256 | Returns all the items that matches all the criteria. | |
257 | ||
258 | =cut | |
259 | ||
260 | sub get { | |
261 | my ($self, %crit) = @_; | |
262 | return map { $self->{items}{$_} } $self->get_keys(%crit); | |
263 | } | |
264 | ||
265 | =item $index->remove_by_key($key) | |
266 | ||
267 | Remove the item identified by the given key. | |
268 | ||
269 | =cut | |
270 | ||
271 | sub remove_by_key { | |
272 | my ($self, $key) = @_; | |
273 | @{$self->{order}} = grep { $_ ne $key } @{$self->{order}}; | |
274 | return delete $self->{items}{$key}; | |
275 | } | |
276 | ||
277 | =item @items = $index->remove(%criteria) | |
278 | ||
279 | Returns and removes all the items that matches all the criteria. | |
280 | ||
281 | =cut | |
282 | ||
283 | sub remove { | |
284 | my ($self, %crit) = @_; | |
285 | my @keys = $self->get_keys(%crit); | |
286 | my (%keys, @ret); | |
287 | foreach my $key (@keys) { | |
288 | $keys{$key} = 1; | |
289 | push @ret, $self->{items}{$key} if defined wantarray; | |
290 | delete $self->{items}{$key}; | |
291 | } | |
292 | @{$self->{order}} = grep { not exists $keys{$_} } @{$self->{order}}; | |
293 | return @ret; | |
294 | } | |
295 | ||
296 | =item $index->merge($other_index, %opts) | |
297 | ||
298 | Merge the entries of the other index. While merging, the keys of the merged | |
299 | index are used, they are not re-computed (unless you have set the options | |
300 | "keep_keys" to "0"). It's your responsibility to ensure that they have been | |
301 | computed with the same function. | |
302 | ||
303 | =cut | |
304 | ||
305 | sub merge { | |
306 | my ($self, $other, %opts) = @_; | |
307 | $opts{keep_keys} //= 1; | |
308 | foreach my $key ($other->get_keys()) { | |
309 | $self->add($other->get_by_key($key), $opts{keep_keys} ? $key : undef); | |
310 | } | |
311 | } | |
312 | ||
313 | =item $index->sort(\&sortfunc) | |
314 | ||
315 | Sort the index with the given sort function. If no function is given, an | |
316 | alphabetic sort is done based on the keys. The sort function receives the | |
317 | items themselves as parameters and not the keys. | |
318 | ||
319 | =cut | |
320 | ||
321 | sub sort { | |
322 | my ($self, $func) = @_; | |
323 | if (defined $func) { | |
324 | @{$self->{order}} = sort { | |
325 | &$func($self->{items}{$a}, $self->{items}{$b}) | |
326 | } @{$self->{order}}; | |
327 | } else { | |
328 | @{$self->{order}} = sort @{$self->{order}}; | |
329 | } | |
330 | } | |
331 | ||
332 | =item $str = $index->output() | |
333 | ||
334 | =item "$index" | |
335 | ||
336 | Get a string representation of the index. The Dpkg::Control objects are | |
337 | output in the order which they have been read or added except if the order | |
338 | have been changed with sort(). | |
339 | ||
340 | =item $index->output($fh) | |
341 | ||
342 | Print the string representation of the index to a filehandle. | |
343 | ||
344 | =cut | |
345 | ||
346 | sub output { | |
347 | my ($self, $fh) = @_; | |
348 | my $str = ''; | |
349 | foreach my $key ($self->get_keys()) { | |
350 | if (defined $fh) { | |
351 | print { $fh } $self->get_by_key($key) . "\n"; | |
352 | } | |
353 | if (defined wantarray) { | |
354 | $str .= $self->get_by_key($key) . "\n"; | |
355 | } | |
356 | } | |
357 | return $str; | |
358 | } | |
359 | ||
360 | =back | |
361 | ||
362 | =head1 CHANGES | |
363 | ||
364 | =head2 Version 1.00 (dpkg 1.15.6) | |
365 | ||
366 | Mark the module as public. | |
367 | ||
368 | =cut | |
369 | ||
370 | 1; |