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
  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     $self->{currversion} = $version;
 532     foreach ($self->items(filter => sub { $_[0] eq '*' })) {
 533         $_->{version} = $self->{currversion};
 534     }
 535     return 1;
 536 }
 537
 538 =item B<$ordinals-E<gt>invalidate>
 539
 540 Invalidates the whole working database.  The practical effect is that all
 541 symbols are set to not exist, but are kept around in the database to retain
 542 ordinal numbers and versions.
 543
 544 =cut
 545
 546 sub invalidate {
 547     my $self = shift;
 548
 549     foreach (@{$self->{contents}}) {
 550         foreach (@{$_ // []}) {
 551             $_->{exists} = 0;
 552         }
 553     }
 554     $self->{stats} = {};
 555 }
 556
 557 =item B<$ordinals-E<gt>validate>
 558
 559 Validates the current working database by collection statistics on how many
 560 symbols were added and how many were changed.  These numbers can be retrieved
 561 with B<$ordinals-E<gt>stats>.
 562
 563 =cut
 564
 565 sub validate {
 566     my $self = shift;
 567
 568     $self->{stats} = {};
 569     for my $i (1..$self->{maxnum}) {
 570         if ($i > $self->{loaded_maxnum}
 571                 || (!@{$self->{loaded_contents}->[$i] // []}
 572                     && @{$self->{contents}->[$i] // []})) {
 573             $self->{stats}->{new}++;
 574         }
 575         next if ($i > $self->{loaded_maxnum});
 576
 577         my @loaded_strings =
 578             map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []};
 579         my @current_strings =
 580             map { $_->to_string() } @{$self->{contents}->[$i] // []};
 581
 582         foreach my $str (@current_strings) {
 583             @loaded_strings = grep { $str ne $_ } @loaded_strings;
 584         }
 585         if (@loaded_strings) {
 586             $self->{stats}->{modified}++;
 587         }
 588     }
 589 }
 590
 591 =item B<$ordinals-E<gt>stats>
 592
 593 Returns the statistics that B<validate> calculate.
 594
 595 =cut
 596
 597 sub stats {
 598     my $self = shift;
 599
 600     return %{$self->{stats}};
 601 }
 602
 603 =back
 604
 605 =head2 Data elements
 606
 607 Data elements, which is each line in an ordinals file, are instances
 608 of a separate class, OpenSSL::Ordinals::Item, with its own methods:
 609
 610 =over 4
 611
 612 =cut
 613
 614 package OpenSSL::Ordinals::Item;
 615
 616 use strict;
 617 use warnings;
 618 use Carp;
 619
 620 =item B<new> I<%options>
 621
 622 Creates a new instance of the C<OpenSSL::Ordinals::Item> class.  It takes
 623 options in keyed pair form, i.e. a series of C<key =E<gt> value> pairs.
 624 Available options are:
 625
 626 =over 4
 627
 628 =item B<from =E<gt> STRING>
 629
 630 This will create a new item, filled with data coming from STRING.
 631
 632 STRING must conform to the following EBNF description:
 633
 634   ordinal string = symbol, spaces, ordinal, spaces, version, spaces,
 635                    exist, ":", platforms, ":", type, ":", features;
 636   spaces         = space, { space };
 637   space          = " " | "\t";
 638   symbol         = ( letter | "_"), { letter | digit | "_" };
 639   ordinal        = number;
 640   version        = number, "_", number, "_", number, [ letter, [ letter ] ];
 641   exist          = "EXIST" | "NOEXIST";
 642   platforms      = platform, { ",", platform };
 643   platform       = ( letter | "_" ) { letter | digit | "_" };
 644   type           = "FUNCTION" | "VARIABLE";
 645   features       = feature, { ",", feature };
 646   feature        = ( letter | "_" ) { letter | digit | "_" };
 647   number         = digit, { digit };
 648
 649 (C<letter> and C<digit> are assumed self evident)
 650
 651 =item B<name =E<gt> STRING>, B<number =E<gt> NUMBER>, B<version =E<gt> STRING>,
 652       B<exists =E<gt> BOOLEAN>, B<type =E<gt> STRING>,
 653       B<platforms =E<gt> HASHref>, B<features =E<gt> LISTref>
 654
 655 This will create a new item with data coming from the arguments.
 656
 657 =back
 658
 659 =cut
 660
 661 sub new {
 662     my $class = shift;
 663
 664     if (ref($_[0]) eq $class) {
 665         return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} );
 666     }
 667
 668     my %opts = @_;
 669
 670     croak "No argument given" unless %opts;
 671
 672     my $instance = undef;
 673     if ($opts{from}) {
 674         my @a = split /\s+/, $opts{from};
 675
 676         croak "Badly formatted ordinals string: $opts{from}"
 677             unless ( scalar @a == 4
 678                      && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
 679                      && $a[1] =~ /^\d+$/
 680                      && $a[2] =~ /^(?:\*|\d+_\d+_\d+[a-z]{0,2})$/
 681                      && $a[3] =~ /^
 682                                   (?:NO)?EXIST:
 683                                   [^:]*:
 684                                   (?:FUNCTION|VARIABLE):
 685                                   [^:]*
 686                                   $
 687                                  /x );
 688
 689         my @b = split /:/, $a[3];
 690         %opts = ( name          => $a[0],
 691                   number        => $a[1],
 692                   version       => $a[2],
 693                   exists        => $b[0] eq 'EXIST',
 694                   platforms     => { map { m|^(!)?|; $' => !$1 }
 695                                          split /,/,$b[1] },
 696                   type          => $b[2],
 697                   features      => [ split /,/,$b[3] // '' ] );
 698     }
 699
 700     if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
 701             && ref($opts{platforms} // {}) eq 'HASH'
 702             && ref($opts{features} // []) eq 'ARRAY') {
 703         my $version = $opts{version};
 704         $version =~ s|_|.|g;
 705
 706         $instance = { name      => $opts{name},
 707                       type      => $opts{type},
 708                       number    => $opts{number},
 709                       version   => $version,
 710                       exists    => !!$opts{exists},
 711                       platforms => { %{$opts{platforms} // {}} },
 712                       features  => [ sort @{$opts{features} // []} ] };
 713     } else {
 714         croak __PACKAGE__."->new() called with bad arguments\n".
 715             join("", map { "    $_\t=> ".$opts{$_}."\n" } sort keys %opts);
 716     }
 717
 718     return bless $instance, $class;
 719 }
 720
 721 sub DESTROY {
 722 }
 723
 724 =item B<$item-E<gt>name>
 725
 726 The symbol name for this item.
 727
 728 =item B<$item-E<gt>number>
 729
 730 The positional number for this item.
 731
 732 =item B<$item-E<gt>version>
 733
 734 The version number for this item.  Please note that these version numbers
 735 have underscore (C<_>) as a separator the the version parts.
 736
 737 =item B<$item-E<gt>exists>
 738
 739 A boolean that tells if this symbol exists in code or not.
 740
 741 =item B<$item-E<gt>platforms>
 742
 743 A hash table reference.  The keys of the hash table are the names of
 744 the specified platforms, with a value of 0 to indicate that this symbol
 745 isn't available on that platform, and 1 to indicate that it is.  Platforms
 746 that aren't mentioned default to 1.
 747
 748 =item B<$item-E<gt>type>
 749
 750 C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
 751 Some platforms do not care about this, others do.
 752
 753 =item B<$item-E<gt>features>
 754
 755 An array reference, where every item indicates a feature where this symbol
 756 is available.  If no features are mentioned, the symbol is always available.
 757 If any feature is mentioned, this symbol is I<only> available when those
 758 features are enabled.
 759
 760 =cut
 761
 762 our $AUTOLOAD;
 763
 764 # Generic getter
 765 sub AUTOLOAD {
 766     my $self = shift;
 767     my $funcname = $AUTOLOAD;
 768     (my $item = $funcname) =~ s|.*::||g;
 769
 770     croak "$funcname called as setter" if @_;
 771     croak "$funcname invalid" unless exists $self->{$item};
 772     return $self->{$item} if ref($self->{$item}) eq '';
 773     return @{$self->{$item}} if ref($self->{$item}) eq 'ARRAY';
 774     return %{$self->{$item}} if ref($self->{$item}) eq 'HASH';
 775 }
 776
 777 =item B<$item-E<gt>to_string>
 778
 779 Converts the item to a string that can be saved in an ordinals file.
 780
 781 =cut
 782
 783 sub to_string {
 784     my $self = shift;
 785
 786     croak "Too many arguments" if @_;
 787     my %platforms = $self->platforms();
 788     my @features = $self->features();
 789     my $version = $self->version();
 790     $version =~ s|\.|_|g;
 791     return sprintf "%-39s %d\t%s\t%s:%s:%s:%s",
 792         $self->name(),
 793         $self->number(),
 794         $version,
 795         $self->exists() ? 'EXIST' : 'NOEXIST',
 796         join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
 797                    sort keys %platforms)),
 798         $self->type(),
 799         join(',', @features);
 800 }
 801
 802 =back
 803
 804 =head2 Comparators and filters
 805
 806 For the B<$ordinals-E<gt>items> method, there are a few functions to create
 807 comparators based on specific data:
 808
 809 =over 4
 810
 811 =cut
 812
 813 # Go back to the main package to create comparators and filters
 814 package OpenSSL::Ordinals;
 815
 816 # Comparators...
 817
 818 =item B<by_name>
 819
 820 Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item
 821 objects.
 822
 823 =cut
 824
 825 sub by_name {
 826     return sub { $_[0]->name() cmp $_[1]->name() };
 827 }
 828
 829 =item B<by_number>
 830
 831 Returns a comparator that will compare the ordinal numbers of two
 832 OpenSSL::Ordinals::Item objects.
 833
 834 =cut
 835
 836 sub by_number {
 837     return sub { $_[0]->number() <=> $_[1]->number() };
 838 }
 839
 840 =item B<by_version>
 841
 842 Returns a comparator that will compare the version of two
 843 OpenSSL::Ordinals::Item objects.
 844
 845 =cut
 846
 847 sub by_version {
 848     return sub {
 849         # cmp_versions comes from OpenSSL::Util
 850         return cmp_versions($_[0]->version(), $_[1]->version());
 851     }
 852 }
 853
 854 =back
 855
 856 There are also the following filters:
 857
 858 =over 4
 859
 860 =cut
 861
 862 # Filters...  these are called by grep, the return sub must use $_ for
 863 # the item to check
 864
 865 =item B<f_version VERSION>
 866
 867 Returns a filter that only lets through symbols with a version number
 868 matching B<VERSION>.
 869
 870 =cut
 871
 872 sub f_version {
 873     my $version = shift;
 874
 875     croak "No version specified"
 876         unless $version && $version =~ /^\d+\.\d+\.\d+[a-z]{0,2}$/;
 877
 878     return sub { $_[0]->version() eq $version };
 879 }
 880
 881 =item B<f_number NUMBER>
 882
 883 Returns a filter that only lets through symbols with the ordinal number
 884 matching B<NUMBER>.
 885
 886 NOTE that this returns a "magic" value that can not be used as a function.
 887 It's only useful when passed directly as a filter to B<items>.
 888
 889 =cut
 890
 891 sub f_number {
 892     my $number = shift;
 893
 894     croak "No number specified"
 895         unless $number && $number =~ /^\d+$/;
 896
 897     return [ F_NUMBER, $number ];
 898 }
 899
 900
 901 =item B<f_name NAME>
 902
 903 Returns a filter that only lets through symbols with the symbol name
 904 matching B<NAME>.
 905
 906 NOTE that this returns a "magic" value that can not be used as a function.
 907 It's only useful when passed directly as a filter to B<items>.
 908
 909 =cut
 910
 911 sub f_name {
 912     my $name = shift;
 913
 914     croak "No name specified"
 915         unless $name;
 916
 917     return [ F_NAME, $name ];
 918 }
 919
 920 =back
 921
 922 =head1 AUTHORS
 923
 924 Richard Levitte E<lt>levitte@openssl.orgE<gt>.
 925
 926 =cut
 927
 928 1;