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