diff options
| -rw-r--r-- | util/perl/OpenSSL/Ordinals.pm | 436 |
1 files changed, 436 insertions, 0 deletions
diff --git a/util/perl/OpenSSL/Ordinals.pm b/util/perl/OpenSSL/Ordinals.pm new file mode 100644 index 0000000000..9d98babd08 --- /dev/null +++ b/util/perl/OpenSSL/Ordinals.pm @@ -0,0 +1,436 @@ +#! /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; |