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 =~ m{^OPENSSL_SYS_})               { $platforms{$'} = $op; }
 346     }
 347
 348     return %platforms;
 349 }
 350
 351 sub _parse_features {
 352     my $self = shift;
 353     my @defs = @_;
 354
 355     my %features = ();
 356     foreach (@defs) {
 357         m{^(!)?};
 358         my $op = !(defined $1 && $1 eq '!');
 359         my $def = $';
 360
 361         if ($def =~ m{^ZLIB$})                      { $features{$&} =  $op; }
 362         if ($def =~ m{^OPENSSL_USE_})               { $features{$'} =  $op; }
 363         if ($def =~ m{^OPENSSL_NO_})                { $features{$'} = !$op; }
 364         if ($def =~ m{^DEPRECATEDIN_(.*)$})         { $features{$&} = !$op; }
 365     }
 366
 367     return %features;
 368 }
 369
 370 sub _adjust_version {
 371     my $self = shift;
 372     my $version = shift;
 373     my $baseversion = $self->{baseversion};
 374
 375     $version = $baseversion
 376         if ($baseversion ne '*' && $version ne '*'
 377             && cmp_versions($baseversion, $version) > 0);
 378
 379     return $version;
 380 }
 381
 382 =item B<$ordinals-E<gt>add NAME, TYPE, LIST>
 383
 384 Adds a new item named NAME with the type TYPE, and a set of C macros in
 385 LIST that are expected to be defined or undefined to use this symbol, if
 386 any.  For undefined macros, they each must be prefixed with a C<!>.
 387
 388 If this symbol already exists in loaded data, it will be rewritten using
 389 the new input data, but will keep the same ordinal number and version.
 390 If it's entirely new, it will get a new number and the current default
 391 version.  The new ordinal number is a simple increment from the last
 392 maximum number.
 393
 394 =cut
 395
 396 sub add {
 397     my $self = shift;
 398     my $name = shift;
 399     my $type = shift;           # FUNCTION or VARIABLE
 400     my @defs = @_;              # Macros from #ifdef and #ifndef
 401                                 # (the latter prefixed with a '!')
 402
 403     # call signature for debug output
 404     my $verbsig = "add('$name' , '$type' , [ " . join(', ', @defs) . " ])";
 405
 406     croak __PACKAGE__."->add got a bad type '$type'"
 407         unless $type eq 'FUNCTION' || $type eq 'VARIABLE';
 408
 409     my %platforms = _parse_platforms(@defs);
 410     my %features = _parse_features(@defs);
 411
 412     my @items = $self->items(filter => f_name($name));
 413     my $version = @items ? $items[0]->version() : $self->{currversion};
 414     my $number = @items ? $items[0]->number() : ++$self->{maxnum};
 415     print STDERR "DEBUG[",__PACKAGE__,":add] $verbsig\n",
 416         @items ? map { "\t".$_->to_string()."\n" } @items : "No previous items\n",
 417         if $self->{debug};
 418     @items = grep { $_->exists() } @items;
 419
 420     my $new_item =
 421         OpenSSL::Ordinals::Item->new( name          => $name,
 422                                       type          => $type,
 423                                       number        => $number,
 424                                       version       =>
 425                                           $self->_adjust_version($version),
 426                                       exists        => 1,
 427                                       platforms     => { %platforms },
 428                                       features      => [
 429                                           grep { $features{$_} } keys %features
 430                                       ] );
 431
 432     push @items, $new_item;
 433     print STDERR "DEBUG[",__PACKAGE__,"::add] $verbsig\n", map { "\t".$_->to_string()."\n" } @items
 434         if $self->{debug};
 435     $self->_putback(@items);
 436
 437     # If an alias was defined beforehand, add an item for it now
 438     my $alias = $self->{aliases}->{$name};
 439     delete $self->{aliases}->{$name};
 440
 441     # For the caller to show
 442     my @returns = ( $new_item );
 443     push @returns, $self->add_alias($alias->{name}, $name, @{$alias->{defs}})
 444         if defined $alias;
 445     return @returns;
 446 }
 447
 448 =item B<$ordinals-E<gt>add_alias ALIAS, NAME, LIST>
 449
 450 Adds an alias ALIAS for the symbol NAME, and a set of C macros in LIST
 451 that are expected to be defined or undefined to use this symbol, if any.
 452 For undefined macros, they each must be prefixed with a C<!>.
 453
 454 If this symbol already exists in loaded data, it will be rewritten using
 455 the new input data.  Otherwise, the data will just be store away, to wait
 456 that the symbol NAME shows up.
 457
 458 =cut
 459
 460 sub add_alias {
 461     my $self = shift;
 462     my $alias = shift;          # This is the alias being added
 463     my $name  = shift;          # For this name (assuming it exists)
 464     my @defs = @_;              # Platform attributes for the alias
 465
 466     # call signature for debug output
 467     my $verbsig =
 468         "add_alias('$alias' , '$name' , [ " . join(', ', @defs) . " ])";
 469
 470     croak "You're kidding me..." if $alias eq $name;
 471
 472     my %platforms = _parse_platforms(@defs);
 473     my %features = _parse_features(@defs);
 474
 475     croak "Alias with associated features is forbidden\n"
 476         if %features;
 477
 478     my $f_byalias = f_name($alias);
 479     my $f_byname = f_name($name);
 480     my @items = $self->items(filter => $f_byalias);
 481     foreach my $item ($self->items(filter => $f_byname)) {
 482         push @items, $item unless grep { $_ == $item } @items;
 483     }
 484     @items = grep { $_->exists() } @items;
 485
 486     croak "Alias already exists ($alias => $name)"
 487         if scalar @items > 1;
 488     if (scalar @items == 0) {
 489         # The item we want to alias for doesn't exist yet, so we cache the
 490         # alias and hope the item we're making an alias of shows up later
 491         $self->{aliases}->{$name} = { name => $alias, defs => [ @defs ] };
 492
 493         print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
 494             "\tSet future alias $alias => $name\n"
 495             if $self->{debug};
 496         return ();
 497     } elsif (scalar @items == 1) {
 498         # The rule is that an alias is more or less a copy of the original
 499         # item, just with another name.  Also, the platforms given here are
 500         # given to the original item as well, with opposite values.
 501         my %alias_platforms = $items[0]->platforms();
 502         foreach (keys %platforms) {
 503             $alias_platforms{$_} = !$platforms{$_};
 504         }
 505         # We supposedly do now know how to do this...  *ahem*
 506         $items[0]->{platforms} = { %alias_platforms };
 507
 508         my $alias_item = OpenSSL::Ordinals::Item->new(
 509             name          => $alias,
 510             type          => $items[0]->type(),
 511             number        => $items[0]->number(),
 512             version       => $self->_adjust_version($items[0]->version()),
 513             exists        => $items[0]->exists(),
 514             platforms     => { %platforms },
 515             features      => [ $items[0]->features() ]
 516            );
 517         push @items, $alias_item;
 518
 519         print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
 520             map { "\t".$_->to_string()."\n" } @items
 521             if $self->{debug};
 522         $self->_putback(@items);
 523
 524         # For the caller to show
 525         return ( $alias_item->to_string() );
 526     }
 527     croak "$name has an alias already (trying to add alias $alias)\n",
 528         "\t", join(", ", map { $_->name() } @items), "\n";
 529 }
 530
 531 =item B<$ordinals-E<gt>set_version VERSION>
 532
 533 =item B<$ordinals-E<gt>set_version VERSION BASEVERSION>
 534
 535 Sets the default version for new symbol to VERSION.
 536
 537 If given, BASEVERSION sets the base version, i.e. the minimum version
 538 for all symbols.  If not given, it will be calculated as follows:
 539
 540 =over 4
 541
 542 If the given version is '*', then the base version will also be '*'.
 543
 544 If the given version starts with '0.', the base version will be '0.0.0'.
 545
 546 If the given version starts with '1.0.', the base version will be '1.0.0'.
 547
 548 If the given version starts with '1.1.', the base version will be '1.1.0'.
 549
 550 If the given version has a first number C<N> that's greater than 1, the
 551 base version will be formed from C<N>: 'N.0.0'.
 552
 553 =back
 554
 555 =cut
 556
 557 sub set_version {
 558     my $self = shift;
 559     # '*' is for "we don't care"
 560     my $version = shift // '*';
 561     my $baseversion = shift // '*';
 562
 563     $version =~ s|-.*||g;
 564
 565     if ($baseversion eq '*') {
 566         $baseversion = $version;
 567         if ($baseversion ne '*') {
 568             if ($baseversion =~ m|^(\d+)\.|, $1 > 1) {
 569                 $baseversion = "$1.0.0";
 570             } else {
 571                 $baseversion =~ s|^0\..*$|0.0.0|;
 572                 $baseversion =~ s|^1\.0\..*$|1.0.0|;
 573                 $baseversion =~ s|^1\.1\..*$|1.1.0|;
 574
 575                 die 'Invalid version'
 576                     if ($baseversion ne '0.0.0'
 577                         && $baseversion !~ m|^1\.[01]\.0$|);
 578             }
 579         }
 580     }
 581
 582     die 'Invalid base version'
 583         if ($baseversion ne '*' && $version ne '*'
 584             && cmp_versions($baseversion, $version) > 0);
 585
 586     $self->{currversion} = $version;
 587     $self->{baseversion} = $baseversion;
 588     foreach ($self->items(filter => sub { $_[0] eq '*' })) {
 589         $_->{version} = $self->{currversion};
 590     }
 591     return 1;
 592 }
 593
 594 =item B<$ordinals-E<gt>invalidate>
 595
 596 Invalidates the whole working database.  The practical effect is that all
 597 symbols are set to not exist, but are kept around in the database to retain
 598 ordinal numbers and versions.
 599
 600 =cut
 601
 602 sub invalidate {
 603     my $self = shift;
 604
 605     foreach (@{$self->{contents}}) {
 606         foreach (@{$_ // []}) {
 607             $_->{exists} = 0;
 608         }
 609     }
 610     $self->{stats} = {};
 611 }
 612
 613 =item B<$ordinals-E<gt>validate>
 614
 615 Validates the current working database by collection statistics on how many
 616 symbols were added and how many were changed.  These numbers can be retrieved
 617 with B<$ordinals-E<gt>stats>.
 618
 619 =cut
 620
 621 sub validate {
 622     my $self = shift;
 623
 624     $self->{stats} = {};
 625     for my $i (1..$self->{maxnum}) {
 626         if ($i > $self->{loaded_maxnum}
 627                 || (!@{$self->{loaded_contents}->[$i] // []}
 628                     && @{$self->{contents}->[$i] // []})) {
 629             $self->{stats}->{new}++;
 630         }
 631         next if ($i > $self->{loaded_maxnum});
 632
 633         my @loaded_strings =
 634             map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []};
 635         my @current_strings =
 636             map { $_->to_string() } @{$self->{contents}->[$i] // []};
 637
 638         foreach my $str (@current_strings) {
 639             @loaded_strings = grep { $str ne $_ } @loaded_strings;
 640         }
 641         if (@loaded_strings) {
 642             $self->{stats}->{modified}++;
 643         }
 644     }
 645 }
 646
 647 =item B<$ordinals-E<gt>stats>
 648
 649 Returns the statistics that B<validate> calculate.
 650
 651 =cut
 652
 653 sub stats {
 654     my $self = shift;
 655
 656     return %{$self->{stats}};
 657 }
 658
 659 =back
 660
 661 =head2 Data elements
 662
 663 Data elements, which is each line in an ordinals file, are instances
 664 of a separate class, OpenSSL::Ordinals::Item, with its own methods:
 665
 666 =over 4
 667
 668 =cut
 669
 670 package OpenSSL::Ordinals::Item;
 671
 672 use strict;
 673 use warnings;
 674 use Carp;
 675
 676 =item B<new> I<%options>
 677
 678 Creates a new instance of the C<OpenSSL::Ordinals::Item> class.  It takes
 679 options in keyed pair form, i.e. a series of C<key =E<gt> value> pairs.
 680 Available options are:
 681
 682 =over 4
 683
 684 =item B<from =E<gt> STRING>
 685
 686 This will create a new item, filled with data coming from STRING.
 687
 688 STRING must conform to the following EBNF description:
 689
 690   ordinal string = symbol, spaces, ordinal, spaces, version, spaces,
 691                    exist, ":", platforms, ":", type, ":", features;
 692   spaces         = space, { space };
 693   space          = " " | "\t";
 694   symbol         = ( letter | "_"), { letter | digit | "_" };
 695   ordinal        = number;
 696   version        = number, "_", number, "_", number, [ letter, [ letter ] ];
 697   exist          = "EXIST" | "NOEXIST";
 698   platforms      = platform, { ",", platform };
 699   platform       = ( letter | "_" ) { letter | digit | "_" };
 700   type           = "FUNCTION" | "VARIABLE";
 701   features       = feature, { ",", feature };
 702   feature        = ( letter | "_" ) { letter | digit | "_" };
 703   number         = digit, { digit };
 704
 705 (C<letter> and C<digit> are assumed self evident)
 706
 707 =item B<name =E<gt> STRING>, B<number =E<gt> NUMBER>, B<version =E<gt> STRING>,
 708       B<exists =E<gt> BOOLEAN>, B<type =E<gt> STRING>,
 709       B<platforms =E<gt> HASHref>, B<features =E<gt> LISTref>
 710
 711 This will create a new item with data coming from the arguments.
 712
 713 =back
 714
 715 =cut
 716
 717 sub new {
 718     my $class = shift;
 719
 720     if (ref($_[0]) eq $class) {
 721         return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} );
 722     }
 723
 724     my %opts = @_;
 725
 726     croak "No argument given" unless %opts;
 727
 728     my $instance = undef;
 729     if ($opts{from}) {
 730         my @a = split /\s+/, $opts{from};
 731
 732         croak "Badly formatted ordinals string: $opts{from}"
 733             unless ( scalar @a == 4
 734                      && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
 735                      && $a[1] =~ /^\d+$/
 736                      && $a[2] =~ /^(?:\*|\d+_\d+_\d+[a-z]{0,2})$/
 737                      && $a[3] =~ /^
 738                                   (?:NO)?EXIST:
 739                                   [^:]*:
 740                                   (?:FUNCTION|VARIABLE):
 741                                   [^:]*
 742                                   $
 743                                  /x );
 744
 745         my @b = split /:/, $a[3];
 746         %opts = ( name          => $a[0],
 747                   number        => $a[1],
 748                   version       => $a[2],
 749                   exists        => $b[0] eq 'EXIST',
 750                   platforms     => { map { m|^(!)?|; $' => !$1 }
 751                                          split /,/,$b[1] },
 752                   type          => $b[2],
 753                   features      => [ split /,/,$b[3] // '' ] );
 754     }
 755
 756     if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
 757             && ref($opts{platforms} // {}) eq 'HASH'
 758             && ref($opts{features} // []) eq 'ARRAY') {
 759         my $version = $opts{version};
 760         $version =~ s|_|.|g;
 761
 762         $instance = { name      => $opts{name},
 763                       type      => $opts{type},
 764                       number    => $opts{number},
 765                       version   => $version,
 766                       exists    => !!$opts{exists},
 767                       platforms => { %{$opts{platforms} // {}} },
 768                       features  => [ sort @{$opts{features} // []} ] };
 769     } else {
 770         croak __PACKAGE__."->new() called with bad arguments\n".
 771             join("", map { "    $_\t=> ".$opts{$_}."\n" } sort keys %opts);
 772     }
 773
 774     return bless $instance, $class;
 775 }
 776
 777 sub DESTROY {
 778 }
 779
 780 =item B<$item-E<gt>name>
 781
 782 The symbol name for this item.
 783
 784 =item B<$item-E<gt>number>
 785
 786 The positional number for this item.
 787
 788 =item B<$item-E<gt>version>
 789
 790 The version number for this item.  Please note that these version numbers
 791 have underscore (C<_>) as a separator the the version parts.
 792
 793 =item B<$item-E<gt>exists>
 794
 795 A boolean that tells if this symbol exists in code or not.
 796
 797 =item B<$item-E<gt>platforms>
 798
 799 A hash table reference.  The keys of the hash table are the names of
 800 the specified platforms, with a value of 0 to indicate that this symbol
 801 isn't available on that platform, and 1 to indicate that it is.  Platforms
 802 that aren't mentioned default to 1.
 803
 804 =item B<$item-E<gt>type>
 805
 806 C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
 807 Some platforms do not care about this, others do.
 808
 809 =item B<$item-E<gt>features>
 810
 811 An array reference, where every item indicates a feature where this symbol
 812 is available.  If no features are mentioned, the symbol is always available.
 813 If any feature is mentioned, this symbol is I<only> available when those
 814 features are enabled.
 815
 816 =cut
 817
 818 our $AUTOLOAD;
 819
 820 # Generic getter
 821 sub AUTOLOAD {
 822     my $self = shift;
 823     my $funcname = $AUTOLOAD;
 824     (my $item = $funcname) =~ s|.*::||g;
 825
 826     croak "$funcname called as setter" if @_;
 827     croak "$funcname invalid" unless exists $self->{$item};
 828     return $self->{$item} if ref($self->{$item}) eq '';
 829     return @{$self->{$item}} if ref($self->{$item}) eq 'ARRAY';
 830     return %{$self->{$item}} if ref($self->{$item}) eq 'HASH';
 831 }
 832
 833 =item B<$item-E<gt>to_string>
 834
 835 Converts the item to a string that can be saved in an ordinals file.
 836
 837 =cut
 838
 839 sub to_string {
 840     my $self = shift;
 841
 842     croak "Too many arguments" if @_;
 843     my %platforms = $self->platforms();
 844     my @features = $self->features();
 845     my $version = $self->version();
 846     $version =~ s|\.|_|g;
 847     return sprintf "%-39s %d\t%s\t%s:%s:%s:%s",
 848         $self->name(),
 849         $self->number(),
 850         $version,
 851         $self->exists() ? 'EXIST' : 'NOEXIST',
 852         join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
 853                    sort keys %platforms)),
 854         $self->type(),
 855         join(',', @features);
 856 }
 857
 858 =back
 859
 860 =head2 Comparators and filters
 861
 862 For the B<$ordinals-E<gt>items> method, there are a few functions to create
 863 comparators based on specific data:
 864
 865 =over 4
 866
 867 =cut
 868
 869 # Go back to the main package to create comparators and filters
 870 package OpenSSL::Ordinals;
 871
 872 # Comparators...
 873
 874 =item B<by_name>
 875
 876 Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item
 877 objects.
 878
 879 =cut
 880
 881 sub by_name {
 882     return sub { $_[0]->name() cmp $_[1]->name() };
 883 }
 884
 885 =item B<by_number>
 886
 887 Returns a comparator that will compare the ordinal numbers of two
 888 OpenSSL::Ordinals::Item objects.
 889
 890 =cut
 891
 892 sub by_number {
 893     return sub { $_[0]->number() <=> $_[1]->number() };
 894 }
 895
 896 =item B<by_version>
 897
 898 Returns a comparator that will compare the version of two
 899 OpenSSL::Ordinals::Item objects.
 900
 901 =cut
 902
 903 sub by_version {
 904     return sub {
 905         # cmp_versions comes from OpenSSL::Util
 906         return cmp_versions($_[0]->version(), $_[1]->version());
 907     }
 908 }
 909
 910 =back
 911
 912 There are also the following filters:
 913
 914 =over 4
 915
 916 =cut
 917
 918 # Filters...  these are called by grep, the return sub must use $_ for
 919 # the item to check
 920
 921 =item B<f_version VERSION>
 922
 923 Returns a filter that only lets through symbols with a version number
 924 matching B<VERSION>.
 925
 926 =cut
 927
 928 sub f_version {
 929     my $version = shift;
 930
 931     croak "No version specified"
 932         unless $version && $version =~ /^\d+\.\d+\.\d+[a-z]{0,2}$/;
 933
 934     return sub { $_[0]->version() eq $version };
 935 }
 936
 937 =item B<f_number NUMBER>
 938
 939 Returns a filter that only lets through symbols with the ordinal number
 940 matching B<NUMBER>.
 941
 942 NOTE that this returns a "magic" value that can not be used as a function.
 943 It's only useful when passed directly as a filter to B<items>.
 944
 945 =cut
 946
 947 sub f_number {
 948     my $number = shift;
 949
 950     croak "No number specified"
 951         unless $number && $number =~ /^\d+$/;
 952
 953     return [ F_NUMBER, $number ];
 954 }
 955
 956
 957 =item B<f_name NAME>
 958
 959 Returns a filter that only lets through symbols with the symbol name
 960 matching B<NAME>.
 961
 962 NOTE that this returns a "magic" value that can not be used as a function.
 963 It's only useful when passed directly as a filter to B<items>.
 964
 965 =cut
 966
 967 sub f_name {
 968     my $name = shift;
 969
 970     croak "No name specified"
 971         unless $name;
 972
 973     return [ F_NAME, $name ];
 974 }
 975
 976 =back
 977
 978 =head1 AUTHORS
 979
 980 Richard Levitte E<lt>levitte@openssl.orgE<gt>.
 981
 982 =cut
 983
 984 1;