util/perl/OpenSSL/Ordinals.pm

   1 #! /usr/bin/env perl
   2 # Copyright 2018 The OpenSSL Project Authors. All Rights Reserved.
   3 #
   4 # Licensed under the Apache License 2.0 (the "License").  You may not use
   5 # this file except in compliance with the License.  You can obtain a copy
   6 # in the file LICENSE in the source distribution or at
   7 # https://www.openssl.org/source/license.html
   8
   9 package OpenSSL::Ordinals;
  10
  11 use strict;
  12 use warnings;
  13 use Carp;
  14 use Scalar::Util qw(blessed);
  15 use OpenSSL::Util;
  16
  17 use constant {
  18     # "magic" filters, see the filters at the end of the file
  19     F_NAME      => 1,
  20     F_NUMBER    => 2,
  21 };
  22
  23 =head1 NAME
  24
  25 OpenSSL::Ordinals - a private module to read and walk through ordinals
  26
  27 =head1 SYNOPSIS
  28
  29   use OpenSSL::Ordinals;
  30
  31   my $ordinals = OpenSSL::Ordinals->new(from => "foo.num");
  32   # or alternatively
  33   my $ordinals = OpenSSL::Ordinals->new();
  34   $ordinals->load("foo.num");
  35
  36   foreach ($ordinals->items(comparator => by_name()) {
  37     print $_->name(), "\n";
  38   }
  39
  40 =head1 DESCRIPTION
  41
  42 This is a OpenSSL private module to load an ordinals (F<.num>) file and
  43 write out the data you want, sorted and filtered according to your rules.
  44
  45 An ordinals file is a file that enumerates all the symbols that a shared
  46 library or loadable module must export.  Each of them have a unique
  47 assigned number as well as other attributes to indicate if they only exist
  48 on a subset of the supported platforms, or if they are specific to certain
  49 features.
  50
  51 The unique numbers each symbol gets assigned needs to be maintained for a
  52 shared library or module to stay compatible with previous versions on
  53 platforms that maintain a transfer vector indexed by position rather than
  54 by name.  They also help keep information on certain symbols that are
  55 aliases for others for certain platforms, or that have different forms
  56 on different platforms.
  57
  58 =head2 Main methods
  59
  60 =over  4
  61
  62 =cut
  63
  64 =item B<new> I<%options>
  65
  66 Creates a new instance of the C<OpenSSL::Ordinals> class.  It takes options
  67 in keyed pair form, i.e. a series of C<< key => value >> pairs.  Available
  68 options are:
  69
  70 =over 4
  71
  72 =item B<< from => FILENAME >>
  73
  74 Not only create a new instance, but immediately load it with data from the
  75 ordinals file FILENAME.
  76
  77 =back
  78
  79 =cut
  80
  81 sub new {
  82     my $class = shift;
  83     my %opts = @_;
  84
  85     my $instance = {
  86         filename        => undef, # File name registered when loading
  87         loaded_maxnum   => 0,     # Highest allocated item number when loading
  88         loaded_contents => [],    # Loaded items, if loading there was
  89         maxassigned     => 0,     # Current highest assigned item number
  90         maxnum          => 0,     # Current highest allocated item number
  91         contents        => [],    # Items, indexed by number
  92         name2num        => {},    # Name to number dictionary
  93         aliases         => {},    # Aliases cache.
  94         stats           => {},    # Statistics, see 'sub validate'
  95         debug           => $opts{debug},
  96     };
  97     bless $instance, $class;
  98
  99     $instance->set_version($opts{version});
 100     $instance->load($opts{from}) if defined($opts{from});
 101
 102     return $instance;
 103 }
 104
 105 =item B<< $ordinals->load FILENAME >>
 106
 107 Loads the data from FILENAME into the instance.  Any previously loaded data
 108 is dropped.
 109
 110 Two internal databases are created.  One database is simply a copy of the file
 111 contents and is treated as read-only.  The other database is an exact copy of
 112 the first, but is treated as a work database, i.e. it can be modified and added
 113 to.
 114
 115 =cut
 116
 117 sub load {
 118     my $self = shift;
 119     my $filename = shift;
 120
 121     croak "Undefined filename" unless defined($filename);
 122
 123     my @tmp_contents = ();
 124     my %tmp_name2num = ();
 125     my $max_assigned = 0;
 126     my $max_num = 0;
 127     open F, '<', $filename or croak "Unable to open $filename";
 128     while (<F>) {
 129         s|\R$||;                # Better chomp
 130         s|#.*||;
 131         next if /^\s*$/;
 132
 133         my $item = OpenSSL::Ordinals::Item->new(from => $_);
 134
 135         my $num = $item->number();
 136         if ($num eq '?') {
 137             $num = ++$max_num;
 138         } elsif ($num eq '?+') {
 139             $num = $max_num;
 140         } else {
 141             croak "Disordered ordinals, number sequence restarted"
 142                 if $max_num > $max_assigned && $num < $max_num;
 143             croak "Disordered ordinals, $num < $max_num"
 144                 if $num < $max_num;
 145             $max_assigned = $max_num = $num;
 146         }
 147
 148         $item->intnum($num);
 149         push @{$tmp_contents[$num]}, $item;
 150         $tmp_name2num{$item->name()} = $num;
 151     }
 152     close F;
 153
 154     $self->{contents} = [ @tmp_contents ];
 155     $self->{name2num} = { %tmp_name2num };
 156     $self->{maxassigned} = $max_assigned;
 157     $self->{maxnum} = $max_num;
 158     $self->{filename} = $filename;
 159
 160     # Make a deep copy, allowing {contents} to be an independent work array
 161     foreach my $i (1..$max_num) {
 162         if ($tmp_contents[$i]) {
 163             $self->{loaded_contents}->[$i] =
 164                 [ map { OpenSSL::Ordinals::Item->new($_) }
 165                   @{$tmp_contents[$i]} ];
 166         }
 167     }
 168     $self->{loaded_maxnum} = $max_num;
 169     return 1;
 170 }
 171
 172 =item B<< $ordinals->renumber >>
 173
 174 Renumber any item that doesn't have an assigned number yet.
 175
 176 =cut
 177
 178 sub renumber {
 179     my $self = shift;
 180
 181     my $max_assigned = 0;
 182     foreach ($self->items(sort => by_number())) {
 183         $_->number($_->intnum()) if $_->number() =~ m|^\?|;
 184         if ($max_assigned < $_->number()) {
 185             $max_assigned = $_->number();
 186         }
 187     }
 188     $self->{maxassigned} = $max_assigned;
 189 }
 190
 191 =item B<< $ordinals->rewrite >>
 192
 193 =item B<< $ordinals->rewrite >>, I<%options>
 194
 195 If an ordinals file has been loaded, it gets rewritten with the data from
 196 the current work database.
 197
 198 If there are more arguments, they are used as I<%options> with the
 199 same semantics as for B<< $ordinals->items >> described below, apart
 200 from B<sort>, which is forbidden here.
 201
 202 =cut
 203
 204 sub rewrite {
 205     my $self = shift;
 206     my %opts = @_;
 207
 208     $self->write($self->{filename}, %opts);
 209 }
 210
 211 =item B<< $ordinals->write FILENAME >>
 212
 213 =item B<< $ordinals->write FILENAME >>, I<%options>
 214
 215 Writes the current work database data to the ordinals file FILENAME.
 216 This also validates the data, see B<< $ordinals->validate >> below.
 217
 218 If there are more arguments, they are used as I<%options> with the
 219 same semantics as for B<< $ordinals->items >> described next, apart
 220 from B<sort>, which is forbidden here.
 221
 222 =cut
 223
 224 sub write {
 225     my $self = shift;
 226     my $filename = shift;
 227     my %opts = @_;
 228
 229     croak "Undefined filename" unless defined($filename);
 230     croak "The 'sort' option is not allowed" if $opts{sort};
 231
 232     $self->validate();
 233
 234     open F, '>', $filename or croak "Unable to open $filename";
 235     foreach ($self->items(%opts, sort => by_number())) {
 236         print F $_->to_string(),"\n";
 237     }
 238     close F;
 239     $self->{filename} = $filename;
 240     $self->{loaded_maxnum} = $self->{maxnum};
 241     return 1;
 242 }
 243
 244 =item B<< $ordinals->items >> I<%options>
 245
 246 Returns a list of items according to a set of criteria.  The criteria is
 247 given in form keyed pair form, i.e. a series of C<< key => value >> pairs.
 248 Available options are:
 249
 250 =over 4
 251
 252 =item B<< sort => SORTFUNCTION >>
 253
 254 SORTFUNCTION is a reference to a function that takes two arguments, which
 255 correspond to the classic C<$a> and C<$b> that are available in a C<sort>
 256 block.
 257
 258 =item B<< filter => FILTERFUNCTION >>
 259
 260 FILTERFUNCTION is a reference to a function that takes one argument, which
 261 is every OpenSSL::Ordinals::Item element available.
 262
 263 =back
 264
 265 =cut
 266
 267 sub items {
 268     my $self = shift;
 269     my %opts = @_;
 270
 271     my $comparator = $opts{sort};
 272     my $filter = $opts{filter} // sub { 1; };
 273
 274     my @l = undef;
 275     if (ref($filter) eq 'ARRAY') {
 276         # run a "magic" filter
 277         if    ($filter->[0] == F_NUMBER) {
 278             my $index = $filter->[1];
 279             @l = $index ? @{$self->{contents}->[$index] // []} : ();
 280         } elsif ($filter->[0] == F_NAME) {
 281             my $index = $self->{name2num}->{$filter->[1]};
 282             @l = $index ? @{$self->{contents}->[$index] // []} : ();
 283         } else {
 284             croak __PACKAGE__."->items called with invalid filter";
 285         }
 286     } elsif (ref($filter) eq 'CODE') {
 287         @l = grep { $filter->($_) }
 288             map { @{$_ // []} }
 289             @{$self->{contents}};
 290     } else {
 291         croak __PACKAGE__."->items called with invalid filter";
 292     }
 293
 294     return sort { $comparator->($a, $b); } @l
 295         if (defined $comparator);
 296     return @l;
 297 }
 298
 299 # Put an array of items back into the object after having checked consistency
 300 # If there are exactly two items:
 301 # - They MUST have the same number
 302 # - For platforms, both MUST hold the same ones, but with opposite values
 303 # - For features, both MUST hold the same ones.
 304 # If there's just one item, just put it in the slot of its number
 305 # In all other cases, something is wrong
 306 sub _putback {
 307     my $self = shift;
 308     my @items = @_;
 309
 310     if (scalar @items < 1 || scalar @items > 2) {
 311         croak "Wrong number of items: ", scalar @items, " : ",
 312             join(", ", map { $_->name() } @items), "\n";
 313     }
 314     if (scalar @items == 2) {
 315         # Collect some data
 316         my %numbers = ();
 317         my %versions = ();
 318         my %features = ();
 319         foreach (@items) {
 320             $numbers{$_->intnum()} = 1;
 321             $versions{$_->version()} = 1;
 322             foreach ($_->features()) {
 323                 $features{$_}++;
 324             }
 325         }
 326
 327         # Check that all items we're trying to put back have the same number
 328         croak "Items don't have the same numeral: ",
 329             join(", ", map { $_->name()." => ".$_->intnum() } @items), "\n"
 330             if (scalar keys %numbers > 1);
 331         croak "Items don't have the same version: ",
 332             join(", ", map { $_->name()." => ".$_->version() } @items), "\n"
 333             if (scalar keys %versions > 1);
 334
 335         # Check that both items run with the same features
 336         foreach (@items) {
 337         }
 338         foreach (keys %features) {
 339             delete $features{$_} if $features{$_} == 2;
 340         }
 341         croak "Features not in common between ",
 342             $items[0]->name(), " and ", $items[1]->name(), ":",
 343             join(", ", sort keys %features), "\n"
 344             if %features;
 345
 346         # Check that all platforms exist in both items, and have opposite values
 347         my @platforms = ( { $items[0]->platforms() },
 348                           { $items[1]->platforms() } );
 349         foreach my $platform (keys %{$platforms[0]}) {
 350             if (exists $platforms[1]->{$platform}) {
 351                 if ($platforms[0]->{$platform} != !$platforms[1]->{$platform}) {
 352                     croak "Platforms aren't opposite: ",
 353                         join(", ",
 354                              map { my %tmp_h = $_->platforms();
 355                                    $_->name().":".$platform
 356                                        ." => "
 357                                        .$tmp_h{$platform} } @items),
 358                         "\n";
 359                 }
 360
 361                 # We're done with these
 362                 delete $platforms[0]->{$platform};
 363                 delete $platforms[1]->{$platform};
 364             }
 365         }
 366         # If there are any remaining platforms, something's wrong
 367         if (%{$platforms[0]} || %{$platforms[0]}) {
 368             croak "There are platforms not in common between ",
 369                 $items[0]->name(), " and ", $items[1]->name(), "\n";
 370         }
 371     }
 372     $self->{contents}->[$items[0]->intnum()] = [ @items ];
 373 }
 374
 375 sub _parse_platforms {
 376     my $self = shift;
 377     my @defs = @_;
 378
 379     my %platforms = ();
 380     foreach (@defs) {
 381         m{^(!)?};
 382         my $op = !(defined $1 && $1 eq '!');
 383         my $def = $';
 384
 385         if ($def =~ m{^_?WIN32$})                   { $platforms{$&} = $op; }
 386         if ($def =~ m{^__FreeBSD__$})               { $platforms{$&} = $op; }
 387 # For future support
 388 #       if ($def =~ m{^__DragonFly__$})             { $platforms{$&} = $op; }
 389 #       if ($def =~ m{^__OpenBSD__$})               { $platforms{$&} = $op; }
 390 #       if ($def =~ m{^__NetBSD__$})                { $platforms{$&} = $op; }
 391         if ($def =~ m{^OPENSSL_SYS_})               { $platforms{$'} = $op; }
 392     }
 393
 394     return %platforms;
 395 }
 396
 397 sub _parse_features {
 398     my $self = shift;
 399     my @defs = @_;
 400
 401     my %features = ();
 402     foreach (@defs) {
 403         m{^(!)?};
 404         my $op = !(defined $1 && $1 eq '!');
 405         my $def = $';
 406
 407         if ($def =~ m{^ZLIB$})                      { $features{$&} =  $op; }
 408         if ($def =~ m{^OPENSSL_USE_})               { $features{$'} =  $op; }
 409         if ($def =~ m{^OPENSSL_NO_})                { $features{$'} = !$op; }
 410     }
 411
 412     return %features;
 413 }
 414
 415 sub _adjust_version {
 416     my $self = shift;
 417     my $version = shift;
 418     my $baseversion = $self->{baseversion};
 419
 420     $version = $baseversion
 421         if ($baseversion ne '*' && $version ne '*'
 422             && cmp_versions($baseversion, $version) > 0);
 423
 424     return $version;
 425 }
 426
 427 =item B<< $ordinals->add NAME, TYPE, LIST >>
 428
 429 Adds a new item named NAME with the type TYPE, and a set of C macros in
 430 LIST that are expected to be defined or undefined to use this symbol, if
 431 any.  For undefined macros, they each must be prefixed with a C<!>.
 432
 433 If this symbol already exists in loaded data, it will be rewritten using
 434 the new input data, but will keep the same ordinal number and version.
 435 If it's entirely new, it will get a '?' and the current default version.
 436
 437 =cut
 438
 439 sub add {
 440     my $self = shift;
 441     my $name = shift;
 442     my $type = shift;           # FUNCTION or VARIABLE
 443     my @defs = @_;              # Macros from #ifdef and #ifndef
 444                                 # (the latter prefixed with a '!')
 445
 446     # call signature for debug output
 447     my $verbsig = "add('$name' , '$type' , [ " . join(', ', @defs) . " ])";
 448
 449     croak __PACKAGE__."->add got a bad type '$type'"
 450         unless $type eq 'FUNCTION' || $type eq 'VARIABLE';
 451
 452     my %platforms = _parse_platforms(@defs);
 453     my %features = _parse_features(@defs);
 454
 455     my @items = $self->items(filter => f_name($name));
 456     my $version = @items ? $items[0]->version() : $self->{currversion};
 457     my $intnum = @items ? $items[0]->intnum() : ++$self->{maxnum};
 458     my $number = @items ? $items[0]->number() : '?';
 459     print STDERR "DEBUG[",__PACKAGE__,":add] $verbsig\n",
 460         @items ? map { "\t".$_->to_string()."\n" } @items : "No previous items\n",
 461         if $self->{debug};
 462     @items = grep { $_->exists() } @items;
 463
 464     my $new_item =
 465         OpenSSL::Ordinals::Item->new( name          => $name,
 466                                       type          => $type,
 467                                       number        => $number,
 468                                       intnum        => $intnum,
 469                                       version       =>
 470                                           $self->_adjust_version($version),
 471                                       exists        => 1,
 472                                       platforms     => { %platforms },
 473                                       features      => [
 474                                           grep { $features{$_} } keys %features
 475                                       ] );
 476
 477     push @items, $new_item;
 478     print STDERR "DEBUG[",__PACKAGE__,"::add] $verbsig\n", map { "\t".$_->to_string()."\n" } @items
 479         if $self->{debug};
 480     $self->_putback(@items);
 481
 482     # If an alias was defined beforehand, add an item for it now
 483     my $alias = $self->{aliases}->{$name};
 484     delete $self->{aliases}->{$name};
 485
 486     # For the caller to show
 487     my @returns = ( $new_item );
 488     push @returns, $self->add_alias($alias->{name}, $name, @{$alias->{defs}})
 489         if defined $alias;
 490     return @returns;
 491 }
 492
 493 =item B<< $ordinals->add_alias ALIAS, NAME, LIST >>
 494
 495 Adds an alias ALIAS for the symbol NAME, and a set of C macros in LIST
 496 that are expected to be defined or undefined to use this symbol, if any.
 497 For undefined macros, they each must be prefixed with a C<!>.
 498
 499 If this symbol already exists in loaded data, it will be rewritten using
 500 the new input data.  Otherwise, the data will just be store away, to wait
 501 that the symbol NAME shows up.
 502
 503 =cut
 504
 505 sub add_alias {
 506     my $self = shift;
 507     my $alias = shift;          # This is the alias being added
 508     my $name  = shift;          # For this name (assuming it exists)
 509     my @defs = @_;              # Platform attributes for the alias
 510
 511     # call signature for debug output
 512     my $verbsig =
 513         "add_alias('$alias' , '$name' , [ " . join(', ', @defs) . " ])";
 514
 515     croak "You're kidding me..." if $alias eq $name;
 516
 517     my %platforms = _parse_platforms(@defs);
 518     my %features = _parse_features(@defs);
 519
 520     croak "Alias with associated features is forbidden\n"
 521         if %features;
 522
 523     my $f_byalias = f_name($alias);
 524     my $f_byname = f_name($name);
 525     my @items = $self->items(filter => $f_byalias);
 526     foreach my $item ($self->items(filter => $f_byname)) {
 527         push @items, $item unless grep { $_ == $item } @items;
 528     }
 529     @items = grep { $_->exists() } @items;
 530
 531     croak "Alias already exists ($alias => $name)"
 532         if scalar @items > 1;
 533     if (scalar @items == 0) {
 534         # The item we want to alias for doesn't exist yet, so we cache the
 535         # alias and hope the item we're making an alias of shows up later
 536         $self->{aliases}->{$name} = { name => $alias, defs => [ @defs ] };
 537
 538         print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
 539             "\tSet future alias $alias => $name\n"
 540             if $self->{debug};
 541         return ();
 542     } elsif (scalar @items == 1) {
 543         # The rule is that an alias is more or less a copy of the original
 544         # item, just with another name.  Also, the platforms given here are
 545         # given to the original item as well, with opposite values.
 546         my %alias_platforms = $items[0]->platforms();
 547         foreach (keys %platforms) {
 548             $alias_platforms{$_} = !$platforms{$_};
 549         }
 550         # We supposedly do now know how to do this...  *ahem*
 551         $items[0]->{platforms} = { %alias_platforms };
 552
 553         my $number =
 554             $items[0]->number() =~ m|^\?| ? '?+' : $items[0]->number();
 555         my $alias_item = OpenSSL::Ordinals::Item->new(
 556             name          => $alias,
 557             type          => $items[0]->type(),
 558             number        => $number,
 559             intnum        => $items[0]->intnum(),
 560             version       => $self->_adjust_version($items[0]->version()),
 561             exists        => $items[0]->exists(),
 562             platforms     => { %platforms },
 563             features      => [ $items[0]->features() ]
 564            );
 565         push @items, $alias_item;
 566
 567         print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
 568             map { "\t".$_->to_string()."\n" } @items
 569             if $self->{debug};
 570         $self->_putback(@items);
 571
 572         # For the caller to show
 573         return ( $alias_item->to_string() );
 574     }
 575     croak "$name has an alias already (trying to add alias $alias)\n",
 576         "\t", join(", ", map { $_->name() } @items), "\n";
 577 }
 578
 579 =item B<< $ordinals->set_version VERSION >>
 580
 581 =item B<< $ordinals->set_version VERSION BASEVERSION >>
 582
 583 Sets the default version for new symbol to VERSION.
 584
 585 If given, BASEVERSION sets the base version, i.e. the minimum version
 586 for all symbols.  If not given, it will be calculated as follows:
 587
 588 =over 4
 589
 590 If the given version is '*', then the base version will also be '*'.
 591
 592 If the given version starts with '0.', the base version will be '0.0.0'.
 593
 594 If the given version starts with '1.0.', the base version will be '1.0.0'.
 595
 596 If the given version starts with '1.1.', the base version will be '1.1.0'.
 597
 598 If the given version has a first number C<N> that's greater than 1, the
 599 base version will be formed from C<N>: 'N.0.0'.
 600
 601 =back
 602
 603 =cut
 604
 605 sub set_version {
 606     my $self = shift;
 607     # '*' is for "we don't care"
 608     my $version = shift // '*';
 609     my $baseversion = shift // '*';
 610
 611     $version =~ s|-.*||g;
 612
 613     if ($baseversion eq '*') {
 614         $baseversion = $version;
 615         if ($baseversion ne '*') {
 616             if ($baseversion =~ m|^(\d+)\.|, $1 > 1) {
 617                 $baseversion = "$1.0.0";
 618             } else {
 619                 $baseversion =~ s|^0\..*$|0.0.0|;
 620                 $baseversion =~ s|^1\.0\..*$|1.0.0|;
 621                 $baseversion =~ s|^1\.1\..*$|1.1.0|;
 622
 623                 die 'Invalid version'
 624                     if ($baseversion ne '0.0.0'
 625                         && $baseversion !~ m|^1\.[01]\.0$|);
 626             }
 627         }
 628     }
 629
 630     die 'Invalid base version'
 631         if ($baseversion ne '*' && $version ne '*'
 632             && cmp_versions($baseversion, $version) > 0);
 633
 634     $self->{currversion} = $version;
 635     $self->{baseversion} = $baseversion;
 636     foreach ($self->items(filter => sub { $_[0] eq '*' })) {
 637         $_->{version} = $self->{currversion};
 638     }
 639     return 1;
 640 }
 641
 642 =item B<< $ordinals->invalidate >>
 643
 644 Invalidates the whole working database.  The practical effect is that all
 645 symbols are set to not exist, but are kept around in the database to retain
 646 ordinal numbers and versions.
 647
 648 =cut
 649
 650 sub invalidate {
 651     my $self = shift;
 652
 653     foreach (@{$self->{contents}}) {
 654         foreach (@{$_ // []}) {
 655             $_->{exists} = 0;
 656         }
 657     }
 658     $self->{stats} = {};
 659 }
 660
 661 =item B<< $ordinals->validate >>
 662
 663 Validates the current working database by collection statistics on how many
 664 symbols were added and how many were changed.  These numbers can be retrieved
 665 with B<< $ordinals->stats >>.
 666
 667 =cut
 668
 669 sub validate {
 670     my $self = shift;
 671
 672     $self->{stats} = {};
 673     for my $i (1..$self->{maxnum}) {
 674         if ($i > $self->{loaded_maxnum}
 675                 || (!@{$self->{loaded_contents}->[$i] // []}
 676                     && @{$self->{contents}->[$i] // []})) {
 677             $self->{stats}->{new}++;
 678         }
 679         if ($i <= $self->{maxassigned}) {
 680             $self->{stats}->{assigned}++;
 681         } else {
 682             $self->{stats}->{unassigned}++;
 683         }
 684         next if ($i > $self->{loaded_maxnum});
 685
 686         my @loaded_strings =
 687             map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []};
 688         my @current_strings =
 689             map { $_->to_string() } @{$self->{contents}->[$i] // []};
 690
 691         foreach my $str (@current_strings) {
 692             @loaded_strings = grep { $str ne $_ } @loaded_strings;
 693         }
 694         if (@loaded_strings) {
 695             $self->{stats}->{modified}++;
 696         }
 697     }
 698 }
 699
 700 =item B<< $ordinals->stats >>
 701
 702 Returns the statistics that B<validate> calculate.
 703
 704 =cut
 705
 706 sub stats {
 707     my $self = shift;
 708
 709     return %{$self->{stats}};
 710 }
 711
 712 =back
 713
 714 =head2 Data elements
 715
 716 Data elements, which is each line in an ordinals file, are instances
 717 of a separate class, OpenSSL::Ordinals::Item, with its own methods:
 718
 719 =over 4
 720
 721 =cut
 722
 723 package OpenSSL::Ordinals::Item;
 724
 725 use strict;
 726 use warnings;
 727 use Carp;
 728
 729 =item B<new> I<%options>
 730
 731 Creates a new instance of the C<OpenSSL::Ordinals::Item> class.  It takes
 732 options in keyed pair form, i.e. a series of C<< key => value >> pairs.
 733 Available options are:
 734
 735 =over 4
 736
 737 =item B<< from => STRING >>
 738
 739 This will create a new item, filled with data coming from STRING.
 740
 741 STRING must conform to the following EBNF description:
 742
 743   ordinal string = symbol, spaces, ordinal, spaces, version, spaces,
 744                    exist, ":", platforms, ":", type, ":", features;
 745   spaces         = space, { space };
 746   space          = " " | "\t";
 747   symbol         = ( letter | "_" ), { letter | digit | "_" };
 748   ordinal        = number | "?" | "?+";
 749   version        = number, "_", number, "_", number, [ letter, [ letter ] ];
 750   exist          = "EXIST" | "NOEXIST";
 751   platforms      = platform, { ",", platform };
 752   platform       = ( letter | "_" ) { letter | digit | "_" };
 753   type           = "FUNCTION" | "VARIABLE";
 754   features       = feature, { ",", feature };
 755   feature        = ( letter | "_" ) { letter | digit | "_" };
 756   number         = digit, { digit };
 757
 758 (C<letter> and C<digit> are assumed self evident)
 759
 760 =item B<< name => STRING >>, B<< number => NUMBER >>, B<< version => STRING >>,
 761       B<< exists => BOOLEAN >>, B<< type => STRING >>,
 762       B<< platforms => HASHref >>, B<< features => LISTref >>
 763
 764 This will create a new item with data coming from the arguments.
 765
 766 =back
 767
 768 =cut
 769
 770 sub new {
 771     my $class = shift;
 772
 773     if (ref($_[0]) eq $class) {
 774         return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} );
 775     }
 776
 777     my %opts = @_;
 778
 779     croak "No argument given" unless %opts;
 780
 781     my $instance = undef;
 782     if ($opts{from}) {
 783         my @a = split /\s+/, $opts{from};
 784
 785         croak "Badly formatted ordinals string: $opts{from}"
 786             unless ( scalar @a == 4
 787                      && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
 788                      && $a[1] =~ /^\d+|\?\+?$/
 789                      && $a[2] =~ /^(?:\*|\d+_\d+_\d+[a-z]{0,2})$/
 790                      && $a[3] =~ /^
 791                                   (?:NO)?EXIST:
 792                                   [^:]*:
 793                                   (?:FUNCTION|VARIABLE):
 794                                   [^:]*
 795                                   $
 796                                  /x );
 797
 798         my @b = split /:/, $a[3];
 799         %opts = ( name          => $a[0],
 800                   number        => $a[1],
 801                   version       => $a[2],
 802                   exists        => $b[0] eq 'EXIST',
 803                   platforms     => { map { m|^(!)?|; $' => !$1 }
 804                                          split /,/,$b[1] },
 805                   type          => $b[2],
 806                   features      => [ split /,/,$b[3] // '' ] );
 807     }
 808
 809     if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
 810             && ref($opts{platforms} // {}) eq 'HASH'
 811             && ref($opts{features} // []) eq 'ARRAY') {
 812         my $version = $opts{version};
 813         $version =~ s|_|.|g;
 814
 815         $instance = { name      => $opts{name},
 816                       type      => $opts{type},
 817                       number    => $opts{number},
 818                       intnum    => $opts{intnum},
 819                       version   => $version,
 820                       exists    => !!$opts{exists},
 821                       platforms => { %{$opts{platforms} // {}} },
 822                       features  => [ sort @{$opts{features} // []} ] };
 823     } else {
 824         croak __PACKAGE__."->new() called with bad arguments\n".
 825             join("", map { "    $_\t=> ".$opts{$_}."\n" } sort keys %opts);
 826     }
 827
 828     return bless $instance, $class;
 829 }
 830
 831 sub DESTROY {
 832 }
 833
 834 =item B<< $item->name >>
 835
 836 The symbol name for this item.
 837
 838 =item B<< $item->number >> (read-write)
 839
 840 The positional number for this item.
 841
 842 This may be '?' for an unassigned symbol, or '?+' for an unassigned symbol
 843 that's an alias for the previous symbol.  '?' and '?+' must be properly
 844 handled by the caller.  The caller may change this to an actual number.
 845
 846 =item B<< $item->version >> (read-only)
 847
 848 The version number for this item.  Please note that these version numbers
 849 have underscore (C<_>) as a separator the the version parts.
 850
 851 =item B<< $item->exists >> (read-only)
 852
 853 A boolean that tells if this symbol exists in code or not.
 854
 855 =item B<< $item->platforms >> (read-only)
 856
 857 A hash table reference.  The keys of the hash table are the names of
 858 the specified platforms, with a value of 0 to indicate that this symbol
 859 isn't available on that platform, and 1 to indicate that it is.  Platforms
 860 that aren't mentioned default to 1.
 861
 862 =item B<< $item->type >> (read-only)
 863
 864 C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
 865 Some platforms do not care about this, others do.
 866
 867 =item B<< $item->features >> (read-only)
 868
 869 An array reference, where every item indicates a feature where this symbol
 870 is available.  If no features are mentioned, the symbol is always available.
 871 If any feature is mentioned, this symbol is I<only> available when those
 872 features are enabled.
 873
 874 =cut
 875
 876 our $AUTOLOAD;
 877
 878 # Generic getter
 879 sub AUTOLOAD {
 880     my $self = shift;
 881     my $funcname = $AUTOLOAD;
 882     (my $item = $funcname) =~ s|.*::||g;
 883
 884     croak "$funcname called as setter" if @_;
 885     croak "$funcname invalid" unless exists $self->{$item};
 886     return $self->{$item} if ref($self->{$item}) eq '';
 887     return @{$self->{$item}} if ref($self->{$item}) eq 'ARRAY';
 888     return %{$self->{$item}} if ref($self->{$item}) eq 'HASH';
 889 }
 890
 891 =item B<< $item->intnum >> (read-write)
 892
 893 Internal positional number.  If I<< $item->number >> is '?' or '?+', the
 894 caller can use this to set a number for its purposes.
 895 If I<< $item->number >> is a number, I<< $item->intnum >> should be the
 896 same
 897
 898 =cut
 899
 900 # Getter/setters
 901 sub intnum {
 902     my $self = shift;
 903     my $value = shift;
 904     my $item = 'intnum';
 905
 906     croak "$item called with extra arguments" if @_;
 907     $self->{$item} = "$value" if defined $value;
 908     return $self->{$item};
 909 }
 910
 911 sub number {
 912     my $self = shift;
 913     my $value = shift;
 914     my $item = 'number';
 915
 916     croak "$item called with extra arguments" if @_;
 917     $self->{$item} = "$value" if defined $value;
 918     return $self->{$item};
 919 }
 920
 921 =item B<< $item->to_string >>
 922
 923 Converts the item to a string that can be saved in an ordinals file.
 924
 925 =cut
 926
 927 sub to_string {
 928     my $self = shift;
 929
 930     croak "Too many arguments" if @_;
 931     my %platforms = $self->platforms();
 932     my @features = $self->features();
 933     my $version = $self->version();
 934     $version =~ s|\.|_|g;
 935     return sprintf "%-39s %s\t%s\t%s:%s:%s:%s",
 936         $self->name(),
 937         $self->number(),
 938         $version,
 939         $self->exists() ? 'EXIST' : 'NOEXIST',
 940         join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
 941                    sort keys %platforms)),
 942         $self->type(),
 943         join(',', @features);
 944 }
 945
 946 =back
 947
 948 =head2 Comparators and filters
 949
 950 For the B<< $ordinals->items >> method, there are a few functions to create
 951 comparators based on specific data:
 952
 953 =over 4
 954
 955 =cut
 956
 957 # Go back to the main package to create comparators and filters
 958 package OpenSSL::Ordinals;
 959
 960 # Comparators...
 961
 962 =item B<by_name>
 963
 964 Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item
 965 objects.
 966
 967 =cut
 968
 969 sub by_name {
 970     return sub { $_[0]->name() cmp $_[1]->name() };
 971 }
 972
 973 =item B<by_number>
 974
 975 Returns a comparator that will compare the ordinal numbers of two
 976 OpenSSL::Ordinals::Item objects.
 977
 978 =cut
 979
 980 sub by_number {
 981     return sub { $_[0]->intnum() <=> $_[1]->intnum() };
 982 }
 983
 984 =item B<by_version>
 985
 986 Returns a comparator that will compare the version of two
 987 OpenSSL::Ordinals::Item objects.
 988
 989 =cut
 990
 991 sub by_version {
 992     return sub {
 993         # cmp_versions comes from OpenSSL::Util
 994         return cmp_versions($_[0]->version(), $_[1]->version());
 995     }
 996 }
 997
 998 =back
 999
1000 There are also the following filters:
1001
1002 =over 4
1003
1004 =cut
1005
1006 # Filters...  these are called by grep, the return sub must use $_ for
1007 # the item to check
1008
1009 =item B<f_version VERSION>
1010
1011 Returns a filter that only lets through symbols with a version number
1012 matching B<VERSION>.
1013
1014 =cut
1015
1016 sub f_version {
1017     my $version = shift;
1018
1019     croak "No version specified"
1020         unless $version && $version =~ /^\d+\.\d+\.\d+[a-z]{0,2}$/;
1021
1022     return sub { $_[0]->version() eq $version };
1023 }
1024
1025 =item B<f_number NUMBER>
1026
1027 Returns a filter that only lets through symbols with the ordinal number
1028 matching B<NUMBER>.
1029
1030 NOTE that this returns a "magic" value that can not be used as a function.
1031 It's only useful when passed directly as a filter to B<items>.
1032
1033 =cut
1034
1035 sub f_number {
1036     my $number = shift;
1037
1038     croak "No number specified"
1039         unless $number && $number =~ /^\d+$/;
1040
1041     return [ F_NUMBER, $number ];
1042 }
1043
1044
1045 =item B<f_name NAME>
1046
1047 Returns a filter that only lets through symbols with the symbol name
1048 matching B<NAME>.
1049
1050 NOTE that this returns a "magic" value that can not be used as a function.
1051 It's only useful when passed directly as a filter to B<items>.
1052
1053 =cut
1054
1055 sub f_name {
1056     my $name = shift;
1057
1058     croak "No name specified"
1059         unless $name;
1060
1061     return [ F_NAME, $name ];
1062 }
1063
1064 =back
1065
1066 =head1 AUTHORS
1067
1068 Richard Levitte E<lt>levitte@openssl.orgE<gt>.
1069
1070 =cut
1071
1072 1;