File Coverage

File:Dpkg/Index.pm
Coverage:42.0%

linestmtbrancondsubpodtimecode
1# Copyright © 2009 Raphaël Hertzog <hertzog@debian.org>
2# Copyright © 2012-2017 Guillem Jover <guillem@debian.org>
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 <https://www.gnu.org/licenses/>.
16
17=encoding utf8
18
19 - 27
=head1 NAME

Dpkg::Index - generic index of control information

=head1 DESCRIPTION

This class represent a set of L<Dpkg::Control> objects.

=cut
28
29package Dpkg::Index 3.00;
30
31
24
24
24
53
24
333
use strict;
32
24
24
24
43
17
527
use warnings;
33
34
24
24
24
374
16
713
use Dpkg::Gettext;
35
24
24
24
408
15
876
use Dpkg::ErrorHandling;
36
24
24
24
446
15
962
use Dpkg::Control;
37
38
24
24
24
47
18
49
use parent qw(Dpkg::Interface::Storable);
39
40use overload
41
0
0
    '@{}' => sub { return $_[0]->{order} },
42
24
24
24
1074
16
113
    fallback => 1;
43
44 - 52
=head1 METHODS

=over 4

=item $index = Dpkg::Index->new(%opts)

Creates a new empty index. See set_options() for more details.

=cut
53
54sub new {
55
117
1
202
    my ($this, %opts) = @_;
56
117
253
    my $class = ref($this) || $this;
57
58    my $self = {
59        items => {},
60        order => [],
61        unique_tuple_key => 1,
62
0
0
        get_key_func => sub { return $_[0]->{Package} },
63
117
723
        type => CTRL_UNKNOWN,
64        item_opts => {},
65    };
66
117
135
    bless $self, $class;
67
117
237
    $self->set_options(%opts);
68
117
207
    if (exists $opts{load}) {
69
0
0
        $self->load($opts{load});
70    }
71
72
117
151
    return $self;
73}
74
75 - 138
=item $index->set_options(%opts)

The "type" option is checked first to define default values for other
options. Here are the relevant options: "get_key_func" is a function
returning a key for the item passed in parameters, "unique_tuple_key" is
a boolean requesting whether the default key should be the unique tuple
(default to true), "item_opts" is a hash reference that will be passed to
the item constructor in the new_item() method.
The index can only contain one item with a given key.
The "get_key_func" function used depends on the type:

=over

=item *

for CTRL_TMPL_SRC, it is the Source field;

=item *

for CTRL_REPO_SRC and CTRL_DSC it is the Package and Version fields
(concatenated with "_") when "unique_tuple_key" is true (the default), or
otherwise the Package field;

=item *

for CTRL_TMPL_PKG it is simply the Package field;

=item *

for CTRL_REPO_PKG and CTRL_DEB it is the Package, Version and
Architecture fields (concatenated with "_") when "unique_tuple_key" is
true (the default) or otherwise the Package field;

=item *

for CTRL_CHANGELOG it is the Source and the Version fields (concatenated
with an intermediary "_");

=item *

for CTRL_TESTS is an integer index (0-based) corresponding to the Tests or
Test-Command field stanza;

=item *

for CTRL_FILE_CHANGES it is the Source, Version and Architecture fields
(concatenated with "_");

=item *

for CTRL_FILE_VENDOR it is the Vendor field;

=item *

for CTRL_FILE_STATUS it is the Package and Architecture fields (concatenated
with "_");

=item *

otherwise it is the Package field by default.

=back

=cut
139
140sub set_options {
141
117
1
179
    my ($self, %opts) = @_;
142
143    # Default values based on type
144
117
162
    if (exists $opts{type}) {
145
117
111
        my $t = $opts{type};
146
117
265
        if ($t == CTRL_TMPL_PKG) {
147
0
0
0
0
            $self->{get_key_func} = sub { return $_[0]->{Package}; };
148        } elsif ($t == CTRL_TMPL_SRC) {
149
0
0
0
0
            $self->{get_key_func} = sub { return $_[0]->{Source}; };
150        } elsif ($t == CTRL_CHANGELOG) {
151            $self->{get_key_func} = sub {
152
1494
1277
                return $_[0]->{Source} . '_' . $_[0]->{Version};
153
108
598
            };
154        } elsif ($t == CTRL_COPYRIGHT_HEADER) {
155            # This is a bit pointless, because the value will almost always
156            # be the same, but guarantees that we use a known field.
157
0
0
0
0
            $self->{get_key_func} = sub { return $_[0]->{Format}; };
158        } elsif ($t == CTRL_COPYRIGHT_FILES) {
159
0
0
0
0
            $self->{get_key_func} = sub { return $_[0]->{Files}; };
160        } elsif ($t == CTRL_COPYRIGHT_LICENSE) {
161
0
0
0
0
            $self->{get_key_func} = sub { return $_[0]->{License}; };
162        } elsif ($t == CTRL_TESTS) {
163            $self->{get_key_func} = sub {
164
27
27
15
54
                return scalar @{$self->{order}};
165
9
109
            };
166        } elsif ($t == CTRL_REPO_SRC or $t == CTRL_DSC) {
167
0
0
            if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) {
168                $self->{get_key_func} = sub {
169
0
0
                    return $_[0]->{Package} . '_' . $_[0]->{Version};
170
0
0
                };
171            } else {
172                $self->{get_key_func} = sub {
173
0
0
                    return $_[0]->{Package};
174
0
0
                };
175            }
176        } elsif ($t == CTRL_REPO_PKG or $t == CTRL_DEB) {
177
0
0
            if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) {
178                $self->{get_key_func} = sub {
179                    return $_[0]->{Package} . '_' . $_[0]->{Version} . '_' .
180
0
0
                           $_[0]->{Architecture};
181
0
0
                };
182            } else {
183                $self->{get_key_func} = sub {
184
0
0
                    return $_[0]->{Package};
185
0
0
                };
186            }
187        } elsif ($t == CTRL_FILE_CHANGES) {
188            $self->{get_key_func} = sub {
189                return $_[0]->{Source} . '_' . $_[0]->{Version} . '_' .
190
0
0
                       $_[0]->{Architecture};
191
0
0
            };
192        } elsif ($t == CTRL_FILE_VENDOR) {
193
0
0
0
0
            $self->{get_key_func} = sub { return $_[0]->{Vendor}; };
194        } elsif ($t == CTRL_FILE_STATUS) {
195            $self->{get_key_func} = sub {
196
0
0
                return $_[0]->{Package} . '_' . $_[0]->{Architecture};
197
0
0
            };
198        }
199    }
200
201    # Options set by the user override default values
202
117
282
    $self->{$_} = $opts{$_} foreach keys %opts;
203}
204
205 - 210
=item $index->get_type()

Returns the type of control information stored. See the type parameter
set during new().

=cut
211
212sub get_type {
213
0
1
0
    my $self = shift;
214
0
0
    return $self->{type};
215}
216
217 - 223
=item $index->add($item, [$key])

Add a new item in the index. If the $key parameter is omitted, the key
will be generated with the get_key_func function (see set_options() for
details).

=cut
224
225sub add {
226
1521
1
1163
    my ($self, $item, $key) = @_;
227
228
1521
2192
    $key //= $self->{get_key_func}($item);
229
1521
1964
    if (not exists $self->{items}{$key}) {
230
1521
1521
874
1315
        push @{$self->{order}}, $key;
231    }
232
1521
2107
    $self->{items}{$key} = $item;
233}
234
235 - 242
=item $index->parse($fh, $desc)

Reads the filehandle and creates all items parsed. When called multiple
times, the parsed stanzas are accumulated.

Returns the number of items parsed.

=cut
243
244sub parse {
245
9
1
13
    my ($self, $fh, $desc) = @_;
246
9
16
    my $item = $self->new_item();
247
9
8
    my $i = 0;
248
9
19
    while ($item->parse($fh, $desc)) {
249
27
65
        $self->add($item);
250
27
29
        $item = $self->new_item();
251
27
41
        $i++;
252    }
253
3
6
    return $i;
254}
255
256 - 267
=item $index->load($file)

Reads the file and creates all items parsed. Returns the number of items
parsed. Handles compressed files transparently based on their extensions.

=item $item = $index->new_item()

Creates a new item. Mainly useful for derived objects that would want
to override this method to return something else than a L<Dpkg::Control>
object.

=cut
268
269sub new_item {
270
0
1
0
    my $self = shift;
271
0
0
0
0
    return Dpkg::Control->new(%{$self->{item_opts}}, type => $self->{type});
272}
273
274 - 278
=item $item = $index->get_by_key($key)

Returns the item identified by $key or undef.

=cut
279
280sub get_by_key {
281
45
1
41
    my ($self, $key) = @_;
282
45
120
    return $self->{items}{$key} if exists $self->{items}{$key};
283
0
0
    return;
284}
285
286 - 294
=item @keys = $index->get_keys(%criteria)

Returns the keys of items that matches all the criteria. The key of the
%criteria hash is a field name and the value is either a regex that needs
to match the field value, or a reference to a function that must return
true and that receives the field value as single parameter, or a scalar
that must be equal to the field value.

=cut
295
296sub get_keys {
297
21
1
23
    my ($self, %crit) = @_;
298
21
21
15
40
    my @selected = @{$self->{order}};
299
21
32
    foreach my $s_crit (keys %crit) { # search criteria
300
0
0
        if (ref($crit{$s_crit}) eq 'Regexp') {
301            @selected = grep {
302
0
0
                exists $self->{items}{$_}{$s_crit} and
303
0
0
                       $self->{items}{$_}{$s_crit} =~ $crit{$s_crit}
304            } @selected;
305        } elsif (ref($crit{$s_crit}) eq 'CODE') {
306            @selected = grep {
307
0
0
0
0
                $crit{$s_crit}->($self->{items}{$_}{$s_crit});
308            } @selected;
309        } else {
310            @selected = grep {
311
0
0
                exists $self->{items}{$_}{$s_crit} and
312
0
0
                       $self->{items}{$_}{$s_crit} eq $crit{$s_crit}
313            } @selected;
314        }
315    }
316
21
36
    return @selected;
317}
318
319 - 323
=item @items = $index->get(%criteria)

Returns all the items that matches all the criteria.

=cut
324
325sub get {
326
0
1
0
    my ($self, %crit) = @_;
327
0
0
0
0
    return map { $self->{items}{$_} } $self->get_keys(%crit);
328}
329
330 - 334
=item $index->remove_by_key($key)

Remove the item identified by the given key.

=cut
335
336sub remove_by_key {
337
0
1
0
    my ($self, $key) = @_;
338
0
0
0
0
0
0
0
0
    @{$self->{order}} = grep { $_ ne $key } @{$self->{order}};
339
0
0
    return delete $self->{items}{$key};
340}
341
342 - 346
=item @items = $index->remove(%criteria)

Returns and removes all the items that matches all the criteria.

=cut
347
348sub remove {
349
0
1
0
    my ($self, %crit) = @_;
350
0
0
    my @keys = $self->get_keys(%crit);
351
0
0
    my (%keys, @ret);
352
0
0
    foreach my $key (@keys) {
353
0
0
        $keys{$key} = 1;
354
0
0
        push @ret, $self->{items}{$key} if defined wantarray;
355
0
0
        delete $self->{items}{$key};
356    }
357
0
0
0
0
0
0
0
0
    @{$self->{order}} = grep { not exists $keys{$_} } @{$self->{order}};
358
0
0
    return @ret;
359}
360
361 - 368
=item $index->merge($other_index, %opts)

Merge the entries of the other index. While merging, the keys of the merged
index are used, they are not re-computed (unless you have set the options
"keep_keys" to "0"). It's your responsibility to ensure that they have been
computed with the same function.

=cut
369
370sub merge {
371
0
1
0
    my ($self, $other, %opts) = @_;
372
0
0
    $opts{keep_keys} //= 1;
373
0
0
    foreach my $key ($other->get_keys()) {
374
0
0
        $self->add($other->get_by_key($key), $opts{keep_keys} ? $key : undef);
375    }
376}
377
378 - 384
=item $index->sort(\&sortfunc)

Sort the index with the given sort function. If no function is given, an
alphabetic sort is done based on the keys. The sort function receives the
items themselves as parameters and not the keys.

=cut
385
386sub sort {
387
0
1
0
    my ($self, $func) = @_;
388
0
0
    if (defined $func) {
389
0
0
        @{$self->{order}} = sort {
390
0
0
            $func->($self->{items}{$a}, $self->{items}{$b})
391
0
0
0
0
        } @{$self->{order}};
392    } else {
393
0
0
0
0
0
0
        @{$self->{order}} = sort @{$self->{order}};
394    }
395}
396
397 - 408
=item $str = $index->output([$fh])

=item "$index"

Get a string representation of the index. The L<Dpkg::Control> objects are
output in the order which they have been read or added except if the order
have been changed with sort().

Print the string representation of the index to a filehandle if $fh has
been passed.

=cut
409
410sub output {
411
21
1
26
    my ($self, $fh) = @_;
412
21
26
    my $str = '';
413
21
38
    foreach my $key ($self->get_keys()) {
414
45
45
        if (defined $fh) {
415
0
0
0
0
            print { $fh } $self->get_by_key($key) . "\n";
416        }
417
45
51
        if (defined wantarray) {
418
45
51
            $str .= $self->get_by_key($key) . "\n";
419        }
420    }
421
21
233
    return $str;
422}
423
424 - 455
=item $index->save($file)

Writes the content of the index in a file. Auto-compresses files
based on their extensions.

=back

=head1 CHANGES

=head2 Version 3.00 (dpkg 1.21.2)

Change behavior: The CTRL_TESTS key now defaults to a stanza index.

=head2 Version 2.01 (dpkg 1.20.6)

New option: Add new "item_opts" option.

=head2 Version 2.00 (dpkg 1.20.0)

Change behavior: The "unique_tuple_key" option now defaults to true.

=head2 Version 1.01 (dpkg 1.19.0)

New option: Add new "unique_tuple_key" option to $index->set_options() to set
better default "get_key_func" options, which will become the default behavior
in 1.20.x.

=head2 Version 1.00 (dpkg 1.15.6)

Mark the module as public.

=cut
456
4571;