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