File Coverage

blib/lib/Dpkg/Index.pm
Criterion Covered Total %
statement 65 143 45.4
branch 14 54 25.9
condition 4 23 17.3
subroutine 16 37 43.2
pod 14 14 100.0
total 113 271 41.7


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