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 =head1 NAME
  17
  18 OpenSSL::Ordinals - a private module to read and walk through ordinals
  19
  20 =head1 SYNOPSIS
  21
  22   use OpenSSL::Ordinals;
  23
  24   my $ordinals = OpenSSL::Ordinals->new(from => "foo.num");
  25   # or alternatively
  26   my $ordinals = OpenSSL::Ordinals->new();
  27   $ordinals->load("foo.num");
  28
  29   foreach ($ordinals->items(comparator => by_name()) {
  30     print $_->name(), "\n";
  31   }
  32
  33 =head1 DESCRIPTION
  34
  35 This is a OpenSSL private module to load an ordinals (F<.num>) file and
  36 write out the data you want, sorted and filtered according to your rules.
  37
  38 An ordinals file is a file that enumerates all the symbols that a shared
  39 library or loadable module must export.  Each of them have a unique
  40 assigned number as well as other attributes to indicate if they only exist
  41 on a subset of the supported platforms, or if they are specific to certain
  42 features.
  43
  44 The unique numbers each symbol gets assigned needs to be maintained for a
  45 shared library or module to stay compatible with previous versions on
  46 platforms that maintain a transfer vector indexed by position rather than
  47 by name.  They also help keep information on certain symbols that are
  48 aliases for others for certain platforms, or that have different forms
  49 on different platforms.
  50
  51 =head2 Main methods
  52
  53 =over  4
  54
  55 =cut
  56
  57 =item B<new> I<%options>
  58
  59 Creates a new instance of the C<OpenSSL::Ordinals> class.  It takes options
  60 in keyed pair form, i.e. a series of C<key =E<gt> value> pairs.  Available
  61 options are:
  62
  63 =over 4
  64
  65 =item B<from =E<gt> FILENAME>
  66
  67 Not only create a new instance, but immediately load it with data from the
  68 ordinals file FILENAME.
  69
  70 =back
  71
  72 =cut
  73
  74 sub new {
  75     my $class = shift;
  76     my %opts = @_;
  77
  78     my $instance = {
  79         contents        => [],    # The items themselves
  80     };
  81     bless $instance, $class;
  82
  83     $instance->load($opts{from}) if defined($opts{from});
  84
  85     return $instance;
  86 }
  87
  88 =item B<$ordinals-E<gt>load FILENAME>
  89
  90 Loads the data from FILENAME into the instance.  Any previously loaded data
  91 is dropped.
  92
  93 =cut
  94
  95 sub load {
  96     my $self = shift;
  97     my $filename = shift;
  98
  99     croak "Bad instance" unless blessed($self);
 100     croak "Undefined filename" unless defined($filename);
 101
 102     my @tmp_contents;
 103     my $max_num = 0;
 104     open F, '<', $filename or croak "Unable to open $filename";
 105     while (<F>) {
 106         s|\R$||;                # Better chomp
 107         s|#.*||;
 108         next if /^\s*$/;
 109
 110         my $item = OpenSSL::Ordinals::Item->new(from => $_);
 111         my $num = $item->number();
 112
 113         croak "Disordered ordinals, $num < $max_num"
 114             if $num < $max_num;
 115
 116         push @tmp_contents, $item;
 117     }
 118     close F;
 119
 120     $self->{contents} = [ @tmp_contents ];
 121     return 1;
 122 }
 123
 124 =item B<$ordinals-E<gt>items> I<%options>
 125
 126 Returns a list of items according to a set of criteria.  The criteria is
 127 given in form keyed pair form, i.e. a series of C<key =E<gt> value> pairs.
 128 Available options are:
 129
 130 =over 4
 131
 132 =item B<sort =E<gt> SORTFUNCTION>
 133
 134 SORTFUNCTION is a reference to a function that takes two arguments, which
 135 correspond to the classic C<$a> and C<$b> that are available in a C<sort>
 136 block.
 137
 138 =item B<filter =E<gt> FILTERFUNCTION>
 139
 140 FILTERFUNTION is a reference to a function that takes one argument, which
 141 is every OpenSSL::Ordinals::Item element available.
 142
 143 =back
 144
 145 =cut
 146
 147 sub items {
 148     my $self = shift;
 149     my %opts = @_;
 150
 151     my $comparator = $opts{sort};
 152     my $filter = $opts{filter} // sub { 1; };
 153
 154     my @l = grep { $filter->($_) } @{$self->{contents}};
 155     return sort { $comparator->($a, $b); } @l
 156         if (defined $comparator);
 157     return @l;
 158 }
 159
 160 =back
 161
 162 =head2 Data elements
 163
 164 Data elements, which is each line in an ordinals file, are instances
 165 of a separate class, OpenSSL::Ordinals::Item, with its own methods:
 166
 167 =over 4
 168
 169 =cut
 170
 171 package OpenSSL::Ordinals::Item;
 172
 173 use strict;
 174 use warnings;
 175 use Carp;
 176
 177 =item B<new> I<%options>
 178
 179 Creates a new instance of the C<OpenSSL::Ordinals::Item> class.  It takes
 180 options in keyed pair form, i.e. a series of C<key =E<gt> value> pairs.
 181 Available options are:
 182
 183 =over 4
 184
 185 =item B<from =E<gt> STRING>
 186
 187 MANDATORY OPTION!
 188
 189 This will create a new item, filled with data coming from STRING.
 190
 191 STRING must conform to the following EBNF description:
 192
 193   ordinal string = symbol, spaces, ordinal, spaces, version, spaces,
 194                    exist, ":", platforms, ":", type, ":", features;
 195   spaces         = space, { space };
 196   space          = " " | "\t";
 197   symbol         = ( letter | "_"), { letter | digit | "_" };
 198   ordinal        = number;
 199   version        = number, "_", number, "_", number, letter, [ letter ];
 200   exist          = "EXIST" | "NOEXIST";
 201   platforms      = platform, { ",", platform };
 202   platform       = ( letter | "_" ) { letter | digit | "_" };
 203   type           = "FUNCTION" | "VARIABLE";
 204   features       = feature, { ",", feature };
 205   feature        = ( letter | "_" ) { letter | digit | "_" };
 206   number         = digit, { digit };
 207
 208 (C<letter> and C<digit> are assumed self evident)
 209
 210 =back
 211
 212 =cut
 213
 214 sub new {
 215     my $class = shift;
 216     my %opts = @_;
 217
 218     my $string = $opts{from};
 219
 220     croak "No ordinals string given" unless defined $string;
 221
 222     my @a = split /\s+/, $string;
 223
 224     croak "Badly formatted ordinals string: $string"
 225         unless ( scalar @a == 4
 226                  && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
 227                  && $a[1] =~ /^\d+$/
 228                  && $a[2] =~ /^\d+_\d+_\d+(?:[a-z]{0,2})$/
 229                  && $a[3] =~ /^
 230                               (?:NO)?EXIST:
 231                               [^:]*:
 232                               (?:FUNCTION|VARIABLE):
 233                               [^:]*
 234                               $
 235                              /x );
 236
 237     my @b = split /:/, $a[3];
 238     my $instance = { name       => $a[0],
 239                      number     => $a[1],
 240                      version    => $a[2],
 241                      exists     => $b[0] eq 'EXIST',
 242                      platforms  => { map { m|^(!)?|; $' => !$1 }
 243                                          split /,/,$b[1] },
 244                      type       => $b[2],
 245                      features   => [ split /,/,$b[3] // '' ] };
 246
 247     return bless $instance, $class;
 248 }
 249
 250 sub DESTROY {
 251 }
 252
 253 =item B<$item-E<gt>name>
 254
 255 The symbol name for this item.
 256
 257 =item B<$item-E<gt>number>
 258
 259 The positional number for this item.
 260
 261 =item B<$item-E<gt>version>
 262
 263 The version number for this item.  Please note that these version numbers
 264 have underscore (C<_>) as a separator the the version parts.
 265
 266 =item B<$item-E<gt>exists>
 267
 268 A boolean that tells if this symbol exists in code or not.
 269
 270 =item B<$item-E<gt>platforms>
 271
 272 A hash table reference.  The keys of the hash table are the names of
 273 the specified platforms, with a value of 0 to indicate that this symbol
 274 isn't available on that platform, and 1 to indicate that it is.  Platforms
 275 that aren't mentioned default to 1.
 276
 277 =item B<$item-E<gt>type>
 278
 279 C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
 280 Some platforms do not care about this, others do.
 281
 282 =item B<$item-E<gt>features>
 283
 284 An array reference, where every item indicates a feature where this symbol
 285 is available.  If no features are mentioned, the symbol is always available.
 286 If any feature is mentioned, this symbol is I<only> available when those
 287 features are enabled.
 288
 289 =cut
 290
 291 our $AUTOLOAD;
 292
 293 # Generic getter
 294 sub AUTOLOAD {
 295     my $self = shift;
 296     my $funcname = $AUTOLOAD;
 297     (my $item = $funcname) =~ s|.*::||g;
 298
 299     croak "$funcname called as setter" if @_;
 300     croak "$funcname invalid" unless exists $self->{$item};
 301     return $self->{$item} if ref($self->{$item}) eq '';
 302     return @{$self->{$item}} if ref($self->{$item}) eq 'ARRAY';
 303     return %{$self->{$item}} if ref($self->{$item}) eq 'HASH';
 304 }
 305
 306 =item B<$item-E<gt>to_string>
 307
 308 Converts the item to a string that can be saved in an ordinals file.
 309
 310 =cut
 311
 312 sub to_string {
 313     my $self = shift;
 314
 315     croak "Too many arguments" if @_;
 316     my %platforms = $self->platforms();
 317     my @features = $self->features();
 318     return sprintf "%-39s %d\t%s\t%s:%s:%s:%s",
 319         $self->name(),
 320         $self->number(),
 321         $self->version(),
 322         $self->exists() ? 'EXIST' : 'NOEXIST',
 323         join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
 324                    sort keys %platforms)),
 325         $self->type(),
 326         join(',', @features);
 327 }
 328
 329 =back
 330
 331 =head2 Comparators and filters
 332
 333 For the B<$ordinals-E<gt>items> method, there are a few functions to create
 334 comparators based on specific data:
 335
 336 =over 4
 337
 338 =cut
 339
 340 # Go back to the main package to create comparators and filters
 341 package OpenSSL::Ordinals;
 342
 343 # Comparators...
 344
 345 =item B<by_name>
 346
 347 Returns a comparator that will compare the names of two OpenSSL::Ordinals::Item
 348 objects.
 349
 350 =cut
 351
 352 sub by_name {
 353     return sub { $_[0]->name() cmp $_[1]->name() };
 354 }
 355
 356 =item B<by_number>
 357
 358 Returns a comparator that will compare the ordinal numbers of two
 359 OpenSSL::Ordinals::Item objects.
 360
 361 =cut
 362
 363 sub by_number {
 364     return sub { $_[0]->number() <=> $_[1]->number() };
 365 }
 366
 367 =item B<by_version>
 368
 369 Returns a comparator that will compare the version of two
 370 OpenSSL::Ordinals::Item objects.
 371
 372 =cut
 373
 374 sub by_version {
 375     sub _ossl_versionsplit {
 376         my $textversion = shift;
 377         my ($major,$minor,$edit,$patch) =
 378             $textversion =~ /^(\d+)_(\d+)_(\d+)([a-z]{0,2})$/;
 379         return ($major,$minor,$edit,$patch);
 380     }
 381
 382     return sub {
 383         my @a_split = _ossl_versionsplit($_[0]->version());
 384         my @b_split = _ossl_versionsplit($_[1]->version());
 385         my $verdict = 0;
 386         while (@a_split) {
 387             if (scalar @a_split == 1) {
 388                 $verdict = $a_split[0] cmp $b_split[0];
 389             } else {
 390                 $verdict = $a_split[0] <=> $b_split[0];
 391             }
 392             shift @a_split;
 393             shift @b_split;
 394             last unless $verdict == 0;
 395         }
 396         $verdict;
 397     };
 398 }
 399
 400 =back
 401
 402 There are also the following filters:
 403
 404 =over 4
 405
 406 =cut
 407
 408 # Filters...  these are called by grep, the return sub must use $_ for
 409 # the item to check
 410
 411 =item B<f_version VERSION>
 412
 413 Returns a filter that only lets through symbols with a version number
 414 matching B<VERSION>.
 415
 416 =cut
 417
 418 sub f_version {
 419     my $version = shift;
 420
 421     $version =~ s|\.|_|g if $version;
 422     croak "No version specified"
 423         unless $version && $version =~ /^\d_\d_\d[a-z]{0,2}$/;
 424
 425     return sub { $_[0]->version() eq $version };
 426 }
 427
 428 =back
 429
 430 =head1 AUTHORS
 431
 432 Richard Levitte E<lt>levitte@openssl.orgE<gt>.
 433
 434 =cut
 435
 436 1;