Add a perl module that deals with ordinals files

Reviewed-by: NTim Hudson <tjh@openssl.org>
(Merged from https://github.com/openssl/openssl/pull/7191)

util/perl/OpenSSL/Ordinals.pm

+#! /usr/bin/env perl
+# Copyright 2018 The OpenSSL Project Authors. All Rights Reserved.
+#
+# Licensed under the OpenSSL license (the "License").  You may not use
+# this file except in compliance with the License.  You can obtain a copy
+# in the file LICENSE in the source distribution or at
+# https://www.openssl.org/source/license.html
+
+package OpenSSL::Ordinals;
+
+use strict;
+use warnings;
+use Carp;
+use Scalar::Util qw(blessed);
+
+=head1 NAME
+
+OpenSSL::Ordinals - a private module to read and walk through ordinals
+
+=head1 SYNOPSIS
+
+  use OpenSSL::Ordinals;
+
+  my $ordinals = OpenSSL::Ordinals->new(from => "foo.num");
+  # or alternatively
+  my $ordinals = OpenSSL::Ordinals->new();
+  $ordinals->load("foo.num");
+
+  foreach ($ordinals->items(comparator => by_name()) {
+    print $_->name(), "\n";
+  }
+
+=head1 DESCRIPTION
+
+This is a OpenSSL private module to load an ordinals (F<.num>) file and
+write out the data you want, sorted and filtered according to your rules.
+
+An ordinals file is a file that enumerates all the symbols that a shared
+library or loadable module must export.  Each of them have a unique
+assigned number as well as other attributes to indicate if they only exist
+on a subset of the supported platforms, or if they are specific to certain
+features.
+
+The unique numbers each symbol gets assigned needs to be maintained for a
+shared library or module to stay compatible with previous versions on
+platforms that maintain a transfer vector indexed by position rather than
+by name.  They also help keep information on certain symbols that are
+aliases for others for certain platforms, or that have different forms
+on different platforms.
+
+=head2 Main methods
+
+=over  4
+
+=cut
+
+=item B<new> I<%options>
+
+Creates a new instance of the C<OpenSSL::Ordinals> class.  It takes options
+in keyed pair form, i.e. a series of C<key =E<gt> value> pairs.  Available
+options are:
+
+=over 4
+
+=item B<from =E<gt> FILENAME>
+
+Not only create a new instance, but immediately load it with data from the
+ordinals file FILENAME.
+
+=back
+
+=cut
+
+sub new {
+    my $class = shift;
+    my %opts = @_;
+
+    my $instance = {
+        contents        => [],    # The items themselves
+    };
+    bless $instance, $class;
+
+    $instance->load($opts{from}) if defined($opts{from});
+
+    return $instance;
+}
+
+=item B<$ordinals-E<gt>load FILENAME>
+
+Loads the data from FILENAME into the instance.  Any previously loaded data
+is dropped.
+
+=cut
+
+sub load {
+    my $self = shift;
+    my $filename = shift;
+
+    croak "Bad instance" unless blessed($self);
+    croak "Undefined filename" unless defined($filename);
+
+    my @tmp_contents;
+    my $max_num = 0;
+    open F, '<', $filename or croak "Unable to open $filename";
+    while (<F>) {
+        s|\R$||;                # Better chomp
+        s|#.*||;
+        next if /^\s*$/;
+
+        my $item = OpenSSL::Ordinals::Item->new(from => $_);
+        my $num = $item->number();
+
+        croak "Disordered ordinals, $num < $max_num"
+            if $num < $max_num;
+
+        push @tmp_contents, $item;
+    }
+    close F;
+
+    $self->{contents} = [ @tmp_contents ];
+    return 1;
+}
+
+=item B<$ordinals-E<gt>items> I<%options>
+
+Returns a list of items according to a set of criteria.  The criteria is
+given in form keyed pair form, i.e. a series of C<key =E<gt> value> pairs.
+Available options are:
+
+=over 4
+
+=item B<sort =E<gt> SORTFUNCTION>
+
+SORTFUNCTION is a reference to a function that takes two arguments, which
+correspond to the classic C<$a> and C<$b> that are available in a C<sort>
+block.
+
+=item B<filter =E<gt> FILTERFUNCTION>
+
+FILTERFUNTION is a reference to a function that takes one argument, which
+is every OpenSSL::Ordinals::Item element available.
+
+=back
+
+=cut
+
+sub items {
+    my $self = shift;
+    my %opts = @_;
+
+    my $comparator = $opts{sort};
+    my $filter = $opts{filter} // sub { 1; };
+
+    my @l = grep { $filter->($_) } @{$self->{contents}};
+    return sort { $comparator->($a, $b); } @l
+        if (defined $comparator);
+    return @l;
+}
+
+=back
+
+=head2 Data elements
+
+Data elements, which is each line in an ordinals file, are instances
+of a separate class, OpenSSL::Ordinals::Item, with its own methods:
+
+=over 4
+
+=cut
+
+package OpenSSL::Ordinals::Item;
+
+use strict;
+use warnings;
+use Carp;
+
+=item B<new> I<%options>
+
+Creates a new instance of the C<OpenSSL::Ordinals::Item> class.  It takes
+options in keyed pair form, i.e. a series of C<key =E<gt> value> pairs.
+Available options are:
+
+=over 4
+
+=item B<from =E<gt> STRING>
+
+MANDATORY OPTION!
+
+This will create a new item, filled with data coming from STRING.
+
+STRING must conform to the following EBNF description:
+
+  ordinal string = symbol, spaces, ordinal, spaces, version, spaces,
+                   exist, ":", platforms, ":", type, ":", features;
+  spaces         = space, { space };
+  space          = " " | "\t";
+  symbol         = ( letter | "_"), { letter | digit | "_" };
+  ordinal        = number;
+  version        = number, "_", number, "_", number, letter, [ letter ];
+  exist          = "EXIST" | "NOEXIST";
+  platforms      = platform, { ",", platform };
+  platform       = ( letter | "_" ) { letter | digit | "_" };
+  type           = "FUNCTION" | "VARIABLE";
+  features       = feature, { ",", feature };
+  feature        = ( letter | "_" ) { letter | digit | "_" };
+  number         = digit, { digit };
+
+(C<letter> and C<digit> are assumed self evident)
+
+=back
+
+=cut
+
+sub new {
+    my $class = shift;
+    my %opts = @_;
+
+    my $string = $opts{from};
+
+    croak "No ordinals string given" unless defined $string;
+
+    my @a = split /\s+/, $string;
+
+    croak "Badly formatted ordinals string: $string"
+        unless ( scalar @a == 4
+                 && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
+                 && $a[1] =~ /^\d+$/
+                 && $a[2] =~ /^\d+_\d+_\d+(?:[a-z]{0,2})$/
+                 && $a[3] =~ /^
+                              (?:NO)?EXIST:
+                              [^:]*:
+                              (?:FUNCTION|VARIABLE):
+                              [^:]*
+                              $
+                             /x );
+
+    my @b = split /:/, $a[3];
+    my $instance = { name       => $a[0],
+                     number     => $a[1],
+                     version    => $a[2],
+                     exists     => $b[0] eq 'EXIST',
+                     platforms  => { map { m|^(!)?|; $' => !$1 }
+                                         split /,/,$b[1] },
+                     type       => $b[2],
+                     features   => [ split /,/,$b[3] // '' ] };
+
+    return bless $instance, $class;
+}
+
+sub DESTROY {
+}
+
+=item B<$item-E<gt>name>
+
+The symbol name for this item.
+
+=item B<$item-E<gt>number>
+
+The positional number for this item.
+
+=item B<$item-E<gt>version>
+
+The version number for this item.  Please note that these version numbers
+have underscore (C<_>) as a separator the the version parts.
+
+=item B<$item-E<gt>exists>
+
+A boolean that tells if this symbol exists in code or not.
+
+=item B<$item-E<gt>platforms>
+
+A hash table reference.  The keys of the hash table are the names of
+the specified platforms, with a value of 0 to indicate that this symbol
+isn't available on that platform, and 1 to indicate that it is.  Platforms
+that aren't mentioned default to 1.
+
+=item B<$item-E<gt>type>
+
+C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
+Some platforms do not care about this, others do.
+
+=item B<$item-E<gt>features>
+
+An array reference, where every item indicates a feature where this symbol
+is available.  If no features are mentioned, the symbol is always available.
+If any feature is mentioned, this symbol is I<only> available when those
+features are enabled.
+
+=cut
+
+our $AUTOLOAD;
+
+# Generic getter
+sub AUTOLOAD {
+    my $self = shift;
+    my $funcname = $AUTOLOAD;
+    (my $item = $funcname) =~ s|.*::||g;
+
+    croak "$funcname called as setter" if @_;
+    croak "$funcname invalid" unless exists $self->{$item};
+    return $self->{$item} if ref($self->{$item}) eq '';
+    return @{$self->{$item}} if ref($self->{$item}) eq 'ARRAY';
+    return %{$self->{$item}} if ref($self->{$item}) eq 'HASH';
+}
+
+=item B<$item-E<gt>to_string>
+
+Converts the item to a string that can be saved in an ordinals file.
+
+=cut
+
+sub to_string {
+    my $self = shift;
+
+    croak "Too many arguments" if @_;
+    my %platforms = $self->platforms();
+    my @features = $self->features();
+    return sprintf "%-39s %d\t%s\t%s:%s:%s:%s",
+        $self->name(),
+        $self->number(),
+        $self->version(),
+        $self->exists() ? 'EXIST' : 'NOEXIST',
+        join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
+                   sort keys %platforms)),
+        $self->type(),
+        join(',', @features);
+}
+
+=back
+
+=head2 Comparators and filters
+
+For the B<$ordinals-E<gt>items> method, there are a few functions to create
+comparators based on specific data:
+
+=over 4
+
+=cut
+
+# Go back to the main package to create comparators and filters
+package OpenSSL::Ordinals;
+
+# Comparators...
+
+=item B<by_name>
+
+Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item
+objects.
+
+=cut
+
+sub by_name {
+    return sub { $_[0]->name() cmp $_[1]->name() };
+}
+
+=item B<by_number>
+
+Returns a comparator that will compare the ordinal numbers of two
+OpenSSL::Ordinals::Item objects.
+
+=cut
+
+sub by_number {
+    return sub { $_[0]->number() <=> $_[1]->number() };
+}
+
+=item B<by_version>
+
+Returns a comparator that will compare the version of two
+OpenSSL::Ordinals::Item objects.
+
+=cut
+
+sub by_version {
+    sub _ossl_versionsplit {
+        my $textversion = shift;
+        my ($major,$minor,$edit,$patch) =
+            $textversion =~ /^(\d+)_(\d+)_(\d+)([a-z]{0,2})$/;
+        return ($major,$minor,$edit,$patch);
+    }
+
+    return sub {
+        my @a_split = _ossl_versionsplit($_[0]->version());
+        my @b_split = _ossl_versionsplit($_[1]->version());
+        my $verdict = 0;
+        while (@a_split) {
+            if (scalar @a_split == 1) {
+                $verdict = $a_split[0] cmp $b_split[0];
+            } else {
+                $verdict = $a_split[0] <=> $b_split[0];
+            }
+            shift @a_split;
+            shift @b_split;
+            last unless $verdict == 0;
+        }
+        $verdict;
+    };
+}
+
+=back
+
+There are also the following filters:
+
+=over 4
+
+=cut
+
+# Filters...  these are called by grep, the return sub must use $_ for
+# the item to check
+
+=item B<f_version VERSION>
+
+Returns a filter that only lets through symbols with a version number
+matching B<VERSION>.
+
+=cut
+
+sub f_version {
+    my $version = shift;
+
+    $version =~ s|\.|_|g if $version;
+    croak "No version specified"
+        unless $version && $version =~ /^\d_\d_\d[a-z]{0,2}$/;
+
+    return sub { $_[0]->version() eq $version };
+}
+
+=back
+
+=head1 AUTHORS
+
+Richard Levitte E<lt>levitte@openssl.orgE<gt>.
+
+=cut
+
+1;