Add code to manipulate the items in OpenSSL::Ordinals
authorRichard Levitte <levitte@openssl.org>
Wed, 3 Oct 2018 15:44:59 +0000 (17:44 +0200)
committerRichard Levitte <levitte@openssl.org>
Thu, 4 Oct 2018 10:45:40 +0000 (12:45 +0200)
This means adding the capability to add new items, to invalidate and
revalidate all the items, and to update the file it came from, as well
as the possibility to create new items from other data than a line
from said file.

While we're at it, we throw in a couple of useful filters.

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

util/perl/OpenSSL/Ordinals.pm

index 9d98bab..07bdf81 100644 (file)
@@ -13,6 +13,12 @@ use warnings;
 use Carp;
 use Scalar::Util qw(blessed);
 
+use constant {
+    # "magic" filters, see the filters at the end of the file
+    F_NAME      => 1,
+    F_NUMBER    => 2,
+};
+
 =head1 NAME
 
 OpenSSL::Ordinals - a private module to read and walk through ordinals
@@ -76,7 +82,16 @@ sub new {
     my %opts = @_;
 
     my $instance = {
-        contents        => [],    # The items themselves
+        filename        => undef, # File name registered when loading
+        loaded_maxnum   => 0,     # Highest allocated item number when loading
+        loaded_contents => [],    # Loaded items, if loading there was
+        maxnum          => 0,     # Current highest allocated item number
+        contents        => [],    # Items, indexed by number
+        name2num        => {},    # Name to number dictionary
+        aliases         => {},    # Aliases cache.
+        stats           => {},    # Statistics, see 'sub validate'
+        currversion     => $opts{version} // '*', # '*' is for "we don't care"
+        debug           => $opts{debug},
     };
     bless $instance, $class;
 
@@ -90,16 +105,21 @@ sub new {
 Loads the data from FILENAME into the instance.  Any previously loaded data
 is dropped.
 
+Two internal databases are created.  One database is simply a copy of the file
+contents and is treated as read-only.  The other database is an exact copy of
+the first, but is treated as a work database, i.e. it can be modified and added
+to.
+
 =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 @tmp_contents = ();
+    my %tmp_name2num = ();
     my $max_num = 0;
     open F, '<', $filename or croak "Unable to open $filename";
     while (<F>) {
@@ -108,16 +128,69 @@ sub load {
         next if /^\s*$/;
 
         my $item = OpenSSL::Ordinals::Item->new(from => $_);
-        my $num = $item->number();
 
+        my $num = $item->number();
         croak "Disordered ordinals, $num < $max_num"
             if $num < $max_num;
+        $max_num = $num;
 
-        push @tmp_contents, $item;
+        push @{$tmp_contents[$item->number()]}, $item;
+        $tmp_name2num{$item->name()} = $item->number();
     }
     close F;
 
     $self->{contents} = [ @tmp_contents ];
+    $self->{name2num} = { %tmp_name2num };
+    $self->{maxnum} = $max_num;
+    $self->{filename} = $filename;
+
+    # Make a deep copy, allowing {contents} to be an independent work array
+    foreach my $i (1..$max_num) {
+        if ($tmp_contents[$i]) {
+            $self->{loaded_contents}->[$i] =
+                [ map { OpenSSL::Ordinals::Item->new($_) }
+                  @{$tmp_contents[$i]} ];
+        }
+    }
+    $self->{loaded_maxnum} = $max_num;
+    return 1;
+}
+
+=item B<$ordinals-E<gt>rewrite>
+
+If an ordinals file has been loaded, it gets rewritten with the data from
+the current work database.
+
+=cut
+
+sub rewrite {
+    my $self = shift;
+
+    $self->write($self->{filename});
+}
+
+=item B<$ordinals-E<gt>write FILENAME>
+
+Writes the current work database data to the ordinals file FILENAME.
+This also validates the data, see B<$ordinals-E<gt>validate> below.
+
+=cut
+
+sub write {
+    my $self = shift;
+    my $filename = shift;
+
+    croak "Undefined filename" unless defined($filename);
+
+    $self->validate();
+
+    open F, '>', $filename or croak "Unable to open $filename";
+    foreach ($self->items(by => by_number())) {
+        print F $_->to_string(),"\n";
+    }
+    close F;
+    $self->{filename} = $filename;
+    $self->{loaded_maxnum} = $self->{maxnum};
     return 1;
 }
 
@@ -151,12 +224,383 @@ sub items {
     my $comparator = $opts{sort};
     my $filter = $opts{filter} // sub { 1; };
 
-    my @l = grep { $filter->($_) } @{$self->{contents}};
+    my @l = undef;
+    if (ref($filter) eq 'ARRAY') {
+        # run a "magic" filter
+        if    ($filter->[0] == F_NUMBER) {
+            my $index = $filter->[1];
+            @l = $index ? @{$self->{contents}->[$index] // []} : ();
+        } elsif ($filter->[0] == F_NAME) {
+            my $index = $self->{name2num}->{$filter->[1]};
+            @l = $index ? @{$self->{contents}->[$index] // []} : ();
+        } else {
+            croak __PACKAGE__."->items called with invalid filter";
+        }
+    } elsif (ref($filter) eq 'CODE') {
+        @l = grep { $filter->($_) }
+            map { @{$_ // []} }
+            @{$self->{contents}};
+    } else {
+        croak __PACKAGE__."->items called with invalid filter";
+    }
+
     return sort { $comparator->($a, $b); } @l
         if (defined $comparator);
     return @l;
 }
 
+# Put an array of items back into the object after having checked consistency
+# If there are exactly two items:
+# - They MUST have the same number
+# - For platforms, both MUST hold the same ones, but with opposite values
+# - For features, both MUST hold the same ones.
+# If there's just one item, just put it in the slot of its number
+# In all other cases, something is wrong
+sub _putback {
+    my $self = shift;
+    my @items = @_;
+
+    if (scalar @items < 1 || scalar @items > 2) {
+        croak "Wrong number of items: ", scalar @items, " : ",
+            join(", ", map { $_->name() } @items), "\n";
+    }
+    if (scalar @items == 2) {
+        # Collect some data
+        my %numbers = ();
+        my %versions = ();
+        my %features = ();
+        foreach (@items) {
+            $numbers{$_->number()} = 1;
+            $versions{$_->version()} = 1;
+            foreach ($_->features()) {
+                $features{$_}++;
+            }
+        }
+
+        # Check that all items we're trying to put back have the same number
+        croak "Items don't have the same numeral: ",
+            join(", ", map { $_->name()." => ".$_->number() } @items), "\n"
+            if (scalar keys %numbers > 1);
+        croak "Items don't have the same version: ",
+            join(", ", map { $_->name()." => ".$_->version() } @items), "\n"
+            if (scalar keys %versions > 1);
+
+        # Check that both items run with the same features
+        foreach (@items) {
+        }
+        foreach (keys %features) {
+            delete $features{$_} if $features{$_} == 2;
+        }
+        croak "Features not in common between ",
+            $items[0]->name(), " and ", $items[1]->name(), ":",
+            join(", ", sort keys %features), "\n"
+            if %features;
+
+        # Check that all platforms exist in both items, and have opposite values
+        my @platforms = ( { $items[0]->platforms() },
+                          { $items[1]->platforms() } );
+        foreach my $platform (keys %{$platforms[0]}) {
+            if (exists $platforms[1]->{$platform}) {
+                if ($platforms[0]->{$platform} != !$platforms[1]->{$platform}) {
+                    croak "Platforms aren't opposite: ",
+                        join(", ",
+                             map { my %tmp_h = $_->platforms();
+                                   $_->name().":".$platform
+                                       ." => "
+                                       .$tmp_h{$platform} } @items),
+                        "\n";
+                }
+
+                # We're done with these
+                delete $platforms[0]->{$platform};
+                delete $platforms[1]->{$platform};
+            }
+        }
+        # If there are any remaining platforms, something's wrong
+        if (%{$platforms[0]} || %{$platforms[0]}) {
+            croak "There are platforms not in common between ",
+                $items[0]->name(), " and ", $items[1]->name(), "\n";
+        }
+    }
+    $self->{contents}->[$items[0]->number()] = [ @items ];
+}
+
+sub _parse_platforms {
+    my $self = shift;
+    my @defs = @_;
+
+    my %platforms = ();
+    foreach (@defs) {
+        m{^(!)?};
+        my $op = !(defined $1 && $1 eq '!');
+        my $def = $';
+
+        if ($def =~ m{^_?WIN32$})                   { $platforms{$&} = $op; }
+        if ($def =~ m{^__FreeBSD__$})               { $platforms{$&} = $op; }
+# For future support
+#       if ($def =~ m{^__DragonFly__$})             { $platforms{$&} = $op; }
+#       if ($def =~ m{^__OpenBSD__$})               { $platforms{$&} = $op; }
+#       if ($def =~ m{^__NetBSD__$})                { $platforms{$&} = $op; }
+        if ($def =~
+            m{^OPENSSL_(EXPORT_VAR_AS_FUNCTION)$})  { $platforms{$1} = $op; }
+        if ($def =~ m{^OPENSSL_SYS_})               { $platforms{$'} = $op; }
+    }
+
+    return %platforms;
+}
+
+sub _parse_features {
+    my $self = shift;
+    my @defs = @_;
+
+    my %features = ();
+    foreach (@defs) {
+        m{^(!)?};
+        my $op = !(defined $1 && $1 eq '!');
+        my $def = $';
+
+        if ($def =~ m{^ZLIB$})                      { $features{$&} =  $op; }
+        if ($def =~ m{^OPENSSL_USE_})               { $features{$'} =  $op; }
+        if ($def =~ m{^OPENSSL_NO_})                { $features{$'} = !$op; }
+        if ($def =~ m{^DEPRECATEDIN_(.*)$})         { $features{$&} = !$op; }
+    }
+
+    return %features;
+}
+
+=item B<$ordinals-E<gt>add NAME, TYPE, LIST>
+
+Adds a new item named NAME with the type TYPE, and a set of C macros in
+LIST that are expected to be defined or undefined to use this symbol, if
+any.  For undefined macros, they each must be prefixed with a C<!>.
+
+If this symbol already exists in loaded data, it will be rewritten using
+the new input data, but will keep the same ordinal number and version.
+If it's entirely new, it will get a new number and the current default
+version.  The new ordinal number is a simple increment from the last
+maximum number.
+
+=cut
+
+sub add {
+    my $self = shift;
+    my $name = shift;
+    my $type = shift;           # FUNCTION or VARIABLE
+    my @defs = @_;              # Macros from #ifdef and #ifndef
+                                # (the latter prefixed with a '!')
+
+    # call signature for debug output
+    my $verbsig = "add('$name' , '$type' , [ " . join(', ', @defs) . " ])";
+
+    croak __PACKAGE__."->add got a bad type '$type'"
+        unless $type eq 'FUNCTION' || $type eq 'VARIABLE';
+
+    my %platforms = _parse_platforms(@defs);
+    my %features = _parse_features(@defs);
+
+    my @items = $self->items(filter => f_name($name));
+    my $version = @items ? $items[0]->version() : $self->{currversion};
+    my $number = @items ? $items[0]->number() : ++$self->{maxnum};
+    print STDERR "DEBUG[",__PACKAGE__,":add] $verbsig\n",
+        @items ? map { "\t".$_->to_string()."\n" } @items : "No previous items\n",
+        if $self->{debug};
+    @items = grep { $_->exists() } @items;
+
+    my $new_item =
+        OpenSSL::Ordinals::Item->new( name          => $name,
+                                      type          => $type,
+                                      number        => $number,
+                                      version       => $version,
+                                      exists        => 1,
+                                      platforms     => { %platforms },
+                                      features      => [
+                                          grep { $features{$_} } keys %features
+                                      ] );
+
+    push @items, $new_item;
+    print STDERR "DEBUG[",__PACKAGE__,"::add] $verbsig\n", map { "\t".$_->to_string()."\n" } @items
+        if $self->{debug};
+    $self->_putback(@items);
+
+    # If an alias was defined beforehand, add an item for it now
+    my $alias = $self->{aliases}->{$name};
+    delete $self->{aliases}->{$name};
+
+    # For the caller to show
+    my @returns = ( $new_item );
+    push @returns, $self->add_alias($alias->{name}, $name, @{$alias->{defs}})
+        if defined $alias;
+    return @returns;
+}
+
+=item B<$ordinals-E<gt>add_alias ALIAS, NAME, LIST>
+
+Adds an alias ALIAS for the symbol NAME, and a set of C macros in LIST
+that are expected to be defined or undefined to use this symbol, if any.
+For undefined macros, they each must be prefixed with a C<!>.
+
+If this symbol already exists in loaded data, it will be rewritten using
+the new input data.  Otherwise, the data will just be store away, to wait
+that the symbol NAME shows up.
+
+=cut
+
+sub add_alias {
+    my $self = shift;
+    my $alias = shift;          # This is the alias being added
+    my $name  = shift;          # For this name (assuming it exists)
+    my @defs = @_;              # Platform attributes for the alias
+
+    # call signature for debug output
+    my $verbsig =
+        "add_alias('$alias' , '$name' , [ " . join(', ', @defs) . " ])";
+
+    croak "You're kidding me..." if $alias eq $name;
+
+    my %platforms = _parse_platforms(@defs);
+    my %features = _parse_features(@defs);
+
+    croak "Alias with associated features is forbidden\n"
+        if %features;
+
+    my $f_byalias = f_name($alias);
+    my $f_byname = f_name($name);
+    my @items = $self->items(filter => $f_byalias);
+    foreach my $item ($self->items(filter => $f_byname)) {
+        push @items, $item unless grep { $_ == $item } @items;
+    }
+    @items = grep { $_->exists() } @items;
+
+    croak "Alias already exists ($alias => $name)"
+        if scalar @items > 1;
+    if (scalar @items == 0) {
+        # The item we want to alias for doesn't exist yet, so we cache the
+        # alias and hope the item we're making an alias of shows up later
+        $self->{aliases}->{$name} = { name => $alias, defs => [ @defs ] };
+
+        print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
+            "\tSet future alias $alias => $name\n"
+            if $self->{debug};
+        return ();
+    } elsif (scalar @items == 1) {
+        # The rule is that an alias is more or less a copy of the original
+        # item, just with another name.  Also, the platforms given here are
+        # given to the original item as well, with opposite values.
+        my %alias_platforms = $items[0]->platforms();
+        foreach (keys %platforms) {
+            $alias_platforms{$_} = !$platforms{$_};
+        }
+        # We supposedly do now know how to do this...  *ahem*
+        $items[0]->{platforms} = { %alias_platforms };
+
+        my $alias_item = OpenSSL::Ordinals::Item->new(
+            name          => $alias,
+            type          => $items[0]->type(),
+            number        => $items[0]->number(),
+            version       => $items[0]->version(),
+            exists        => $items[0]->exists(),
+            platforms     => { %platforms },
+            features      => [ $items[0]->features() ]
+           );
+        push @items, $alias_item;
+
+        print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
+            map { "\t".$_->to_string()."\n" } @items
+            if $self->{debug};
+        $self->_putback(@items);
+
+        # For the caller to show
+        return ( $alias_item->to_string() );
+    }
+    croak "$name has an alias already (trying to add alias $alias)\n",
+        "\t", join(", ", map { $_->name() } @items), "\n";
+}
+
+=item B<$ordinals-E<gt>set_version VERSION>
+
+Sets the default version for new symbol to VERSION.
+
+=cut
+
+sub set_version {
+    my $self = shift;
+    my $version = shift;
+
+    $version //= '*';
+    $version =~ s|-.*||g;
+    $version =~ s|\.|_|g;
+    $self->{currversion} = $version;
+    foreach ($self->items(filter => sub { $_[0] eq '*' })) {
+        $_->{version} = $self->{currversion};
+    }
+    return 1;
+}
+
+=item B<$ordinals-E<gt>invalidate>
+
+Invalidates the whole working database.  The practical effect is that all
+symbols are set to not exist, but are kept around in the database to retain
+ordinal numbers and versions.
+
+=cut
+
+sub invalidate {
+    my $self = shift;
+
+    foreach (@{$self->{contents}}) {
+        foreach (@{$_ // []}) {
+            $_->{exists} = 0;
+        }
+    }
+    $self->{stats} = {};
+}
+
+=item B<$ordinals-E<gt>validate>
+
+Validates the current working database by collection statistics on how many
+symbols were added and how many were changed.  These numbers can be retrieved
+with B<$ordinals-E<gt>stats>.
+
+=cut
+
+sub validate {
+    my $self = shift;
+
+    $self->{stats} = {};
+    for my $i (1..$self->{maxnum}) {
+        if ($i > $self->{loaded_maxnum}
+                || (!@{$self->{loaded_contents}->[$i] // []}
+                    && @{$self->{contents}->[$i] // []})) {
+            $self->{stats}->{new}++;
+        }
+        next if ($i > $self->{loaded_maxnum});
+
+        my @loaded_strings =
+            map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []};
+        my @current_strings =
+            map { $_->to_string() } @{$self->{contents}->[$i] // []};
+
+        foreach my $str (@current_strings) {
+            @loaded_strings = grep { $str ne $_ } @loaded_strings;
+        }
+        if (@loaded_strings) {
+            $self->{stats}->{modified}++;
+        }
+    }
+}
+
+=item B<$ordinals-E<gt>stats>
+
+Returns the statistics that B<validate> calculate.
+
+=cut
+
+sub stats {
+    my $self = shift;
+
+    return %{$self->{stats}};
+}
+
 =back
 
 =head2 Data elements
@@ -184,8 +628,6 @@ Available options are:
 
 =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:
@@ -207,42 +649,69 @@ STRING must conform to the following EBNF description:
 
 (C<letter> and C<digit> are assumed self evident)
 
+=item B<name =E<gt> STRING>, B<number =E<gt> NUMBER>, B<version =E<gt> STRING>,
+      B<exists =E<gt> BOOLEAN>, B<type =E<gt> STRING>,
+      B<platforms =E<gt> HASHref>, B<features =E<gt> LISTref>
+
+This will create a new item with data coming from the arguments.
+
 =back
 
 =cut
 
 sub new {
     my $class = shift;
+
+    if (ref($_[0]) eq $class) {
+        return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} );
+    }
+
     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 }
+    croak "No argument given" unless %opts;
+
+    my $instance = undef;
+    if ($opts{from}) {
+        my @a = split /\s+/, $opts{from};
+
+        croak "Badly formatted ordinals string: $opts{from}"
+            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];
+        %opts = ( 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] // '' ] };
+                  type          => $b[2],
+                  features      => [ split /,/,$b[3] // '' ] );
+    }
+
+    if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
+            && ref($opts{platforms} // {}) eq 'HASH'
+            && ref($opts{features} // []) eq 'ARRAY') {
+        $instance = { name      => $opts{name},
+                      type      => $opts{type},
+                      number    => $opts{number},
+                      version   => $opts{version},
+                      exists    => !!$opts{exists},
+                      platforms => { %{$opts{platforms} // {}} },
+                      features  => [ sort @{$opts{features} // []} ] };
+    } else {
+        croak __PACKAGE__."->new() called with bad arguments\n".
+            join("", map { "    $_\t=> ".$opts{$_}."\n" } sort keys %opts);
+    }
 
     return bless $instance, $class;
 }
@@ -374,6 +843,7 @@ OpenSSL::Ordinals::Item objects.
 sub by_version {
     sub _ossl_versionsplit {
         my $textversion = shift;
+        return $textversion if $textversion eq '*';
         my ($major,$minor,$edit,$patch) =
             $textversion =~ /^(\d+)_(\d+)_(\d+)([a-z]{0,2})$/;
         return ($major,$minor,$edit,$patch);
@@ -384,6 +854,7 @@ sub by_version {
         my @b_split = _ossl_versionsplit($_[1]->version());
         my $verdict = 0;
         while (@a_split) {
+            # The last part is a letter sequence (or a '*')
             if (scalar @a_split == 1) {
                 $verdict = $a_split[0] cmp $b_split[0];
             } else {
@@ -425,6 +896,45 @@ sub f_version {
     return sub { $_[0]->version() eq $version };
 }
 
+=item B<f_number NUMBER>
+
+Returns a filter that only lets through symbols with the ordinal number
+matching B<NUMBER>.
+
+NOTE that this returns a "magic" value that can not be used as a function.
+It's only useful when passed directly as a filter to B<items>.
+
+=cut
+
+sub f_number {
+    my $number = shift;
+
+    croak "No number specified"
+        unless $number && $number =~ /^\d+$/;
+
+    return [ F_NUMBER, $number ];
+}
+
+
+=item B<f_name NAME>
+
+Returns a filter that only lets through symbols with the symbol name
+matching B<NAME>.
+
+NOTE that this returns a "magic" value that can not be used as a function.
+It's only useful when passed directly as a filter to B<items>.
+
+=cut
+
+sub f_name {
+    my $name = shift;
+
+    croak "No name specified"
+        unless $name;
+
+    return [ F_NAME, $name ];
+}
+
 =back
 
 =head1 AUTHORS