source: vbox/trunk/src/libs/openssl-3.0.2/util/perl/OpenSSL/Config/Query.pm@ 94403

# Copyright 2021 The OpenSSL Project Authors. All Rights Reserved.
#
# Licensed under the Apache License 2.0 (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::Config::Query;

use 5.10.0;
use strict;
use warnings;
use Carp;

=head1 NAME

OpenSSL::Config::Query - Query OpenSSL configuration info

=head1 SYNOPSIS

    use OpenSSL::Config::Info;

    my $query = OpenSSL::Config::Query->new(info => \%unified_info);

    # Query for something that's expected to give a scalar back
    my $variable = $query->method(... args ...);

    # Query for something that's expected to give a list back
    my @variable = $query->method(... args ...);

=head1 DESCRIPTION

The unified info structure, commonly known as the %unified_info table, has
become quite complex, and a bit overwhelming to look through directly.  This
module makes querying this structure simpler, through diverse methods.

=head2 Constructor

=over 4

=item B<new> I<%options>

Creates an instance of the B<OpenSSL::Config::Query> class.  It takes options
in keyed pair form, i.e. a series of C<< key => value >> pairs.  Available
options are:

=over 4

=item B<info> =E<gt> I<HASHREF>

A reference to a unified information hash table, most commonly known as
%unified_info.

=item B<config> =E<gt> I<HASHREF>

A reference to a config information hash table, most commonly known as
%config.

=back

Example:

    my $info = OpenSSL::Config::Info->new(info => \%unified_info);

=back

=cut

sub new {
    my $class = shift;
    my %opts = @_;

    my @messages = _check_accepted_options(\%opts,
                                           info => 'HASH',
                                           config => 'HASH');
    croak $messages[0] if @messages;

    # We make a shallow copy of the input structure.  We might make
    # a different choice in the future...
    my $instance = { info => $opts{info} // {},
                     config => $opts{config} // {} };
    bless $instance, $class;

    return $instance;
}

=head2 Query methods

=over 4

=item B<get_sources> I<LIST>

LIST is expected to be the collection of names of end products, such as
programs, modules, libraries.

The returned result is a hash table reference, with each key being one of
these end product names, and its value being a reference to an array of
source file names that constitutes everything that will or may become part
of that end product.

=cut

sub get_sources {
    my $self = shift;

    my $result = {};
    foreach (@_) {
        my @sources = @{$self->{info}->{sources}->{$_} // []};
        my @staticlibs =
            grep { $_ =~ m|\.a$| } @{$self->{info}->{depends}->{$_} // []};

        my %parts = ( %{$self->get_sources(@sources)},
                      %{$self->get_sources(@staticlibs)} );
        my @parts = map { @{$_} } values %parts;

        my @generator =
            ( ( $self->{info}->{generate}->{$_} // [] ) -> [0] // () );
        my %generator_parts = %{$self->get_sources(@generator)};
        # if there are any generator parts, we ignore it, because that means
        # it's a compiled program and thus NOT part of the source that's
        # queried.
        @generator = () if %generator_parts;

        my @partial_result =
            ( ( map { @{$_} } values %parts ),
              ( grep { !defined($parts{$_}) } @sources, @generator ) );

        # Push conditionally, to avoid creating $result->{$_} with an empty
        # value
        push @{$result->{$_}}, @partial_result if @partial_result;
    }

    return $result;
}

=item B<get_config> I<LIST>

LIST is expected to be the collection of names of configuration data, such
as build_infos, sourcedir, ...

The returned result is a hash table reference, with each key being one of
these configuration data names, and its value being a reference to the value
corresponding to that name.

=cut

sub get_config {
    my $self = shift;

    return { map { $_ => $self->{config}->{$_} } @_ };
}

########
#
#  Helper functions
#

sub _check_accepted_options {
    my $opts = shift;           # HASH reference (hopefully)
    my %conds = @_;             # key => type

    my @messages;
    my %optnames = map { $_ => 1 } keys %$opts;
    foreach (keys %conds) {
        delete $optnames{$_};
    }
    push @messages, "Unknown options: " . join(', ', sort keys %optnames)
        if keys %optnames;
    foreach (sort keys %conds) {
        push @messages, "'$_' value not a $conds{$_} reference"
            if (defined $conds{$_} && defined $opts->{$_}
                && ref $opts->{$_} ne $conds{$_});
    }
    return @messages;
}

1;