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