scripts/Dpkg/Index.pm

   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 =head1 NAME
  20
  21 Dpkg::Index - generic index of control information
  22
  23 =head1 DESCRIPTION
  24
  25 This class represent a set of Dpkg::Control objects.
  26
  27 =cut
  28
  29 package Dpkg::Index 3.00;
  30
  31 use strict;
  32 use warnings;
  33
  34 use Dpkg::Gettext;
  35 use Dpkg::ErrorHandling;
  36 use Dpkg::Control;
  37
  38 use parent qw(Dpkg::Interface::Storable);
  39
  40 use overload
  41     '@{}' => sub { return $_[0]->{order} },
  42     fallback => 1;
  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     my ($this, %opts) = @_;
  56     my $class = ref($this) || $this;
  57
  58     my $self = {
  59         items => {},
  60         order => [],
  61         unique_tuple_key => 1,
  62         get_key_func => sub { return $_[0]->{Package} },
  63         type => CTRL_UNKNOWN,
  64         item_opts => {},
  65     };
  66     bless $self, $class;
  67     $self->set_options(%opts);
  68     if (exists $opts{load}) {
  69         $self->load($opts{load});
  70     }
  71
  72     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 an integer index (0-based) corresponding to the Tests or
 116 Test-Command field stanza;
 117
 118 =item *
 119
 120 for CTRL_FILE_CHANGES it is the Source, Version and Architecture fields
 121 (concatenated with "_");
 122
 123 =item *
 124
 125 for CTRL_FILE_VENDOR it is the Vendor field;
 126
 127 =item *
 128
 129 for CTRL_FILE_STATUS it is the Package and Architecture fields (concatenated
 130 with "_");
 131
 132 =item *
 133
 134 otherwise it is the Package field by default.
 135
 136 =back
 137
 138 =cut
 139
 140 sub set_options {
 141     my ($self, %opts) = @_;
 142
 143     # Default values based on type
 144     if (exists $opts{type}) {
 145         my $t = $opts{type};
 146         if ($t == CTRL_INFO_PKG) {
 147             $self->{get_key_func} = sub { return $_[0]->{Package}; };
 148         } elsif ($t == CTRL_INFO_SRC) {
 149             $self->{get_key_func} = sub { return $_[0]->{Source}; };
 150         } elsif ($t == CTRL_CHANGELOG) {
 151             $self->{get_key_func} = sub {
 152                 return $_[0]->{Source} . '_' . $_[0]->{Version};
 153             };
 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             $self->{get_key_func} = sub { return $_[0]->{Format}; };
 158         } elsif ($t == CTRL_COPYRIGHT_FILES) {
 159             $self->{get_key_func} = sub { return $_[0]->{Files}; };
 160         } elsif ($t == CTRL_COPYRIGHT_LICENSE) {
 161             $self->{get_key_func} = sub { return $_[0]->{License}; };
 162         } elsif ($t == CTRL_TESTS) {
 163             $self->{get_key_func} = sub {
 164                 return scalar @{$self->{order}};
 165             };
 166         } elsif ($t == CTRL_INDEX_SRC or $t == CTRL_PKG_SRC) {
 167             if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) {
 168                 $self->{get_key_func} = sub {
 169                     return $_[0]->{Package} . '_' . $_[0]->{Version};
 170                 };
 171             } else {
 172                 $self->{get_key_func} = sub {
 173                     return $_[0]->{Package};
 174                 };
 175             }
 176         } elsif ($t == CTRL_INDEX_PKG or $t == CTRL_PKG_DEB) {
 177             if ($opts{unique_tuple_key} // $self->{unique_tuple_key}) {
 178                 $self->{get_key_func} = sub {
 179                     return $_[0]->{Package} . '_' . $_[0]->{Version} . '_' .
 180                            $_[0]->{Architecture};
 181                 };
 182             } else {
 183                 $self->{get_key_func} = sub {
 184                     return $_[0]->{Package};
 185                 };
 186             }
 187         } elsif ($t == CTRL_FILE_CHANGES) {
 188             $self->{get_key_func} = sub {
 189                 return $_[0]->{Source} . '_' . $_[0]->{Version} . '_' .
 190                        $_[0]->{Architecture};
 191             };
 192         } elsif ($t == CTRL_FILE_VENDOR) {
 193             $self->{get_key_func} = sub { return $_[0]->{Vendor}; };
 194         } elsif ($t == CTRL_FILE_STATUS) {
 195             $self->{get_key_func} = sub {
 196                 return $_[0]->{Package} . '_' . $_[0]->{Architecture};
 197             };
 198         }
 199     }
 200
 201     # Options set by the user override default values
 202     $self->{$_} = $opts{$_} foreach keys %opts;
 203 }
 204
 205 =item $index->get_type()
 206
 207 Returns the type of control information stored. See the type parameter
 208 set during new().
 209
 210 =cut
 211
 212 sub get_type {
 213     my $self = shift;
 214     return $self->{type};
 215 }
 216
 217 =item $index->add($item, [$key])
 218
 219 Add a new item in the index. If the $key parameter is omitted, the key
 220 will be generated with the get_key_func function (see set_options() for
 221 details).
 222
 223 =cut
 224
 225 sub add {
 226     my ($self, $item, $key) = @_;
 227
 228     $key //= $self->{get_key_func}($item);
 229     if (not exists $self->{items}{$key}) {
 230         push @{$self->{order}}, $key;
 231     }
 232     $self->{items}{$key} = $item;
 233 }
 234
 235 =item $index->parse($fh, $desc)
 236
 237 Reads the filehandle and creates all items parsed. When called multiple
 238 times, the parsed stanzas are accumulated.
 239
 240 Returns the number of items parsed.
 241
 242 =cut
 243
 244 sub parse {
 245     my ($self, $fh, $desc) = @_;
 246     my $item = $self->new_item();
 247     my $i = 0;
 248     while ($item->parse($fh, $desc)) {
 249         $self->add($item);
 250         $item = $self->new_item();
 251         $i++;
 252     }
 253     return $i;
 254 }
 255
 256 =item $index->load($file)
 257
 258 Reads the file and creates all items parsed. Returns the number of items
 259 parsed. Handles compressed files transparently based on their extensions.
 260
 261 =item $item = $index->new_item()
 262
 263 Creates a new item. Mainly useful for derived objects that would want
 264 to override this method to return something else than a Dpkg::Control
 265 object.
 266
 267 =cut
 268
 269 sub new_item {
 270     my $self = shift;
 271     return Dpkg::Control->new(%{$self->{item_opts}}, type => $self->{type});
 272 }
 273
 274 =item $item = $index->get_by_key($key)
 275
 276 Returns the item identified by $key or undef.
 277
 278 =cut
 279
 280 sub get_by_key {
 281     my ($self, $key) = @_;
 282     return $self->{items}{$key} if exists $self->{items}{$key};
 283     return;
 284 }
 285
 286 =item @keys = $index->get_keys(%criteria)
 287
 288 Returns the keys of items that matches all the criteria. The key of the
 289 %criteria hash is a field name and the value is either a regex that needs
 290 to match the field value, or a reference to a function that must return
 291 true and that receives the field value as single parameter, or a scalar
 292 that must be equal to the field value.
 293
 294 =cut
 295
 296 sub get_keys {
 297     my ($self, %crit) = @_;
 298     my @selected = @{$self->{order}};
 299     foreach my $s_crit (keys %crit) { # search criteria
 300         if (ref($crit{$s_crit}) eq 'Regexp') {
 301             @selected = grep {
 302                 exists $self->{items}{$_}{$s_crit} and
 303                        $self->{items}{$_}{$s_crit} =~ $crit{$s_crit}
 304             } @selected;
 305         } elsif (ref($crit{$s_crit}) eq 'CODE') {
 306             @selected = grep {
 307                 $crit{$s_crit}->($self->{items}{$_}{$s_crit});
 308             } @selected;
 309         } else {
 310             @selected = grep {
 311                 exists $self->{items}{$_}{$s_crit} and
 312                        $self->{items}{$_}{$s_crit} eq $crit{$s_crit}
 313             } @selected;
 314         }
 315     }
 316     return @selected;
 317 }
 318
 319 =item @items = $index->get(%criteria)
 320
 321 Returns all the items that matches all the criteria.
 322
 323 =cut
 324
 325 sub get {
 326     my ($self, %crit) = @_;
 327     return map { $self->{items}{$_} } $self->get_keys(%crit);
 328 }
 329
 330 =item $index->remove_by_key($key)
 331
 332 Remove the item identified by the given key.
 333
 334 =cut
 335
 336 sub remove_by_key {
 337     my ($self, $key) = @_;
 338     @{$self->{order}} = grep { $_ ne $key } @{$self->{order}};
 339     return delete $self->{items}{$key};
 340 }
 341
 342 =item @items = $index->remove(%criteria)
 343
 344 Returns and removes all the items that matches all the criteria.
 345
 346 =cut
 347
 348 sub remove {
 349     my ($self, %crit) = @_;
 350     my @keys = $self->get_keys(%crit);
 351     my (%keys, @ret);
 352     foreach my $key (@keys) {
 353         $keys{$key} = 1;
 354         push @ret, $self->{items}{$key} if defined wantarray;
 355         delete $self->{items}{$key};
 356     }
 357     @{$self->{order}} = grep { not exists $keys{$_} } @{$self->{order}};
 358     return @ret;
 359 }
 360
 361 =item $index->merge($other_index, %opts)
 362
 363 Merge the entries of the other index. While merging, the keys of the merged
 364 index are used, they are not re-computed (unless you have set the options
 365 "keep_keys" to "0"). It's your responsibility to ensure that they have been
 366 computed with the same function.
 367
 368 =cut
 369
 370 sub merge {
 371     my ($self, $other, %opts) = @_;
 372     $opts{keep_keys} //= 1;
 373     foreach my $key ($other->get_keys()) {
 374         $self->add($other->get_by_key($key), $opts{keep_keys} ? $key : undef);
 375     }
 376 }
 377
 378 =item $index->sort(\&sortfunc)
 379
 380 Sort the index with the given sort function. If no function is given, an
 381 alphabetic sort is done based on the keys. The sort function receives the
 382 items themselves as parameters and not the keys.
 383
 384 =cut
 385
 386 sub sort {
 387     my ($self, $func) = @_;
 388     if (defined $func) {
 389         @{$self->{order}} = sort {
 390             $func->($self->{items}{$a}, $self->{items}{$b})
 391         } @{$self->{order}};
 392     } else {
 393         @{$self->{order}} = sort @{$self->{order}};
 394     }
 395 }
 396
 397 =item $str = $index->output([$fh])
 398
 399 =item "$index"
 400
 401 Get a string representation of the index. The L<Dpkg::Control> objects are
 402 output in the order which they have been read or added except if the order
 403 have been changed with sort().
 404
 405 Print the string representation of the index to a filehandle if $fh has
 406 been passed.
 407
 408 =cut
 409
 410 sub output {
 411     my ($self, $fh) = @_;
 412     my $str = '';
 413     foreach my $key ($self->get_keys()) {
 414         if (defined $fh) {
 415             print { $fh } $self->get_by_key($key) . "\n";
 416         }
 417         if (defined wantarray) {
 418             $str .= $self->get_by_key($key) . "\n";
 419         }
 420     }
 421     return $str;
 422 }
 423
 424 =item $index->save($file)
 425
 426 Writes the content of the index in a file. Auto-compresses files
 427 based on their extensions.
 428
 429 =back
 430
 431 =head1 CHANGES
 432
 433 =head2 Version 3.00 (dpkg 1.21.2)
 434
 435 Change behavior: The CTRL_TESTS key now defaults to a stanza index.
 436
 437 =head2 Version 2.01 (dpkg 1.20.6)
 438
 439 New option: Add new "item_opts" option.
 440
 441 =head2 Version 2.00 (dpkg 1.20.0)
 442
 443 Change behavior: The "unique_tuple_key" option now defaults to true.
 444
 445 =head2 Version 1.01 (dpkg 1.19.0)
 446
 447 New option: Add new "unique_tuple_key" option to $index->set_options() to set
 448 better default "get_key_func" options, which will become the default behavior
 449 in 1.20.x.
 450
 451 =head2 Version 1.00 (dpkg 1.15.6)
 452
 453 Mark the module as public.
 454
 455 =cut
 456
 457 1;