aboutsummaryrefslogtreecommitdiff
path: root/util/perl/OpenSSL
diff options
context:
space:
mode:
authorCy Schubert <cy@FreeBSD.org>2024-02-02 04:39:16 +0000
committerCy Schubert <cy@FreeBSD.org>2024-02-02 09:48:38 +0000
commit9dd13e84fa8eca8f3462bd55485aa3da8c37f54a (patch)
tree588240aeb9a7363618b8a687c72588bd74948634 /util/perl/OpenSSL
parent825caf7e12445fa4818413cc37c8b45bebb6c3a9 (diff)
OpenSSL: Vendor import of OpenSSL 3.0.13vendor/openssl/3.0.13
* Fixed PKCS12 Decoding crashes ([CVE-2024-0727]) * Fixed Excessive time spent checking invalid RSA public keys ([CVE-2023-6237]) * Fixed POLY1305 MAC implementation corrupting vector registers on PowerPC CPUs which support PowerISA 2.07 ([CVE-2023-6129]) * Fix excessive time spent in DH check / generation with large Q parameter value ([CVE-2023-5678]) Release notes can be found at https://www.openssl.org/news/openssl-3.0-notes.html.
Diffstat (limited to 'util/perl/OpenSSL')
-rw-r--r--util/perl/OpenSSL/Config/Query.pm177
-rw-r--r--util/perl/OpenSSL/Glob.pm21
-rw-r--r--util/perl/OpenSSL/OID.pm307
-rw-r--r--util/perl/OpenSSL/Ordinals.pm1087
-rw-r--r--util/perl/OpenSSL/ParseC.pm1209
-rw-r--r--util/perl/OpenSSL/Template.pm150
-rw-r--r--util/perl/OpenSSL/Test.pm1301
-rw-r--r--util/perl/OpenSSL/Test/Simple.pm91
-rw-r--r--util/perl/OpenSSL/Test/Utils.pm241
-rw-r--r--util/perl/OpenSSL/Util.pm310
-rw-r--r--util/perl/OpenSSL/Util/Pod.pm193
-rwxr-xr-xutil/perl/OpenSSL/config.pm1038
-rw-r--r--util/perl/OpenSSL/copyright.pm43
-rw-r--r--util/perl/OpenSSL/fallback.pm127
-rw-r--r--util/perl/OpenSSL/stackhash.pm106
15 files changed, 6401 insertions, 0 deletions
diff --git a/util/perl/OpenSSL/Config/Query.pm b/util/perl/OpenSSL/Config/Query.pm
new file mode 100644
index 000000000000..22d6a459bdde
--- /dev/null
+++ b/util/perl/OpenSSL/Config/Query.pm
@@ -0,0 +1,177 @@
+# 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;
diff --git a/util/perl/OpenSSL/Glob.pm b/util/perl/OpenSSL/Glob.pm
new file mode 100644
index 000000000000..ec87da4aea9c
--- /dev/null
+++ b/util/perl/OpenSSL/Glob.pm
@@ -0,0 +1,21 @@
+package OpenSSL::Glob;
+
+use strict;
+use warnings;
+
+use File::Glob;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = '0.1';
+@ISA = qw(Exporter);
+@EXPORT = qw(glob);
+
+sub glob {
+ goto &File::Glob::bsd_glob if $^O ne "VMS";
+ goto &CORE::glob;
+}
+
+1;
+__END__
diff --git a/util/perl/OpenSSL/OID.pm b/util/perl/OpenSSL/OID.pm
new file mode 100644
index 000000000000..0b39ef9fd27f
--- /dev/null
+++ b/util/perl/OpenSSL/OID.pm
@@ -0,0 +1,307 @@
+# Copyright 2016-2020 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
+
+# Author note: this is originally RL::ASN1::OID,
+# repurposed by the author for OpenSSL use.
+
+package OpenSSL::OID;
+
+use 5.10.0;
+use strict;
+use warnings;
+use Carp;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+@ISA = qw(Exporter);
+@EXPORT = qw(parse_oid encode_oid register_oid
+ registered_oid_arcs registered_oid_leaves);
+@EXPORT_OK = qw(encode_oid_nums);
+
+# Unfortunately, the pairwise List::Util functionality came with perl
+# v5.19.3, and I want to target absolute compatibility with perl 5.10
+# and up. That means I have to implement quick pairwise functions here.
+
+#use List::Util;
+sub _pairs (@);
+sub _pairmap (&@);
+
+=head1 NAME
+
+OpenSSL::OID - an OBJECT IDENTIFIER parser / encoder
+
+=head1 VERSION
+
+Version 0.1
+
+=cut
+
+our $VERSION = '0.1';
+
+
+=head1 SYNOPSIS
+
+ use OpenSSL::OID;
+
+ # This gives the array ( 1 2 840 113549 1 1 )
+ my @nums = parse_oid('{ pkcs-1 1 }');
+
+ # This gives the array of DER encoded bytes for the OID, i.e.
+ # ( 42, 134, 72, 134, 247, 13, 1, 1 )
+ my @bytes = encode_oid('{ pkcs-1 1 }');
+
+ # This registers a name with an OID. It's saved internally and
+ # serves as repository of names for further parsing, such as 'pkcs-1'
+ # in the strings used above.
+ register_object('pkcs-1', '{ pkcs 1 }');
+
+
+ use OpenSSL::OID qw(:DEFAULT encode_oid_nums);
+
+ # This does the same as encode_oid(), but takes the output of
+ # parse_oid() as input.
+ my @bytes = encode_oid_nums(@nums);
+
+=head1 EXPORT
+
+The functions parse_oid and encode_oid are exported by default.
+The function encode_oid_nums() can be exported explicitly.
+
+=cut
+
+######## REGEXPS
+
+# ASN.1 object identifiers come in two forms: 1) the bracketed form
+#(referred to as ObjectIdentifierValue in X.690), 2) the dotted form
+#(referred to as XMLObjIdentifierValue in X.690)
+#
+# examples of 1 (these are all the OID for rsaEncrypted):
+#
+# { iso (1) 2 840 11349 1 1 }
+# { pkcs 1 1 }
+# { pkcs1 1 }
+#
+# examples of 2:
+#
+# 1.2.840.113549.1.1
+# pkcs.1.1
+# pkcs1.1
+#
+my $identifier_re = qr/[a-z](?:[-_A-Za-z0-9]*[A-Za-z0-9])?/;
+# The only difference between $objcomponent_re and $xmlobjcomponent_re is
+# the separator in the top branch. Each component is always parsed in two
+# groups, so we get a pair of values regardless. That's the reason for the
+# empty parentheses.
+# Because perl doesn't try to do an exhaustive try of every branch it rather
+# stops on the first that matches, we need to have them in order of longest
+# to shortest where there may be ambiguity.
+my $objcomponent_re = qr/(?|
+ (${identifier_re}) \s* \((\d+)\)
+ |
+ (${identifier_re}) ()
+ |
+ ()(\d+)
+ )/x;
+my $xmlobjcomponent_re = qr/(?|
+ (${identifier_re}) \. \((\d+)\)
+ |
+ (${identifier_re}) ()
+ |
+ () (\d+)
+ )/x;
+
+my $obj_re =
+ qr/(?: \{ \s* (?: ${objcomponent_re} \s+ )* ${objcomponent_re} \s* \} )/x;
+my $xmlobj_re =
+ qr/(?: (?: ${xmlobjcomponent_re} \. )* ${xmlobjcomponent_re} )/x;
+
+######## NAME TO OID REPOSITORY
+
+# Recorded OIDs, to support things like '{ pkcs1 1 }'
+# Do note that we don't currently support relative OIDs
+#
+# The key is the identifier.
+#
+# The value is a hash, composed of:
+# type => 'arc' | 'leaf'
+# nums => [ LIST ]
+# Note that the |type| always starts as a 'leaf', and may change to an 'arc'
+# on the fly, as new OIDs are parsed.
+my %name2oid = ();
+
+########
+
+=head1 SUBROUTINES/METHODS
+
+=over 4
+
+=item parse_oid()
+
+TBA
+
+=cut
+
+sub parse_oid {
+ my $input = shift;
+
+ croak "Invalid extra arguments" if (@_);
+
+ # The components become a list of ( identifier, number ) pairs,
+ # where they can also be the empty string if they are not present
+ # in the input.
+ my @components;
+ if ($input =~ m/^\s*(${obj_re})\s*$/x) {
+ my $oid = $1;
+ @components = ( $oid =~ m/${objcomponent_re}\s*/g );
+ } elsif ($input =~ m/^\s*(${xmlobj_re})\s*$/) {
+ my $oid = $1;
+ @components = ( $oid =~ m/${xmlobjcomponent_re}\.?/g );
+ }
+
+ croak "Invalid ASN.1 object '$input'" unless @components;
+ die "Internal error when parsing '$input'"
+ unless scalar(@components) % 2 == 0;
+
+ # As we currently only support a name without number as first
+ # component, the easiest is to have a direct look at it and
+ # hack it.
+ my @first = _pairmap {
+ my ($a, $b) = @$_;
+ return $b if $b ne '';
+ return @{$name2oid{$a}->{nums}} if $a ne '' && defined $name2oid{$a};
+ croak "Undefined identifier $a" if $a ne '';
+ croak "Empty OID element (how's that possible?)";
+ } ( @components[0..1] );
+
+ my @numbers =
+ (
+ @first,
+ _pairmap {
+ my ($a, $b) = @$_;
+ return $b if $b ne '';
+ croak "Unsupported relative OID $a" if $a ne '';
+ croak "Empty OID element (how's that possible?)";
+ } @components[2..$#components]
+ );
+
+ # If the first component has an identifier and there are other
+ # components following it, we change the type of that identifier
+ # to 'arc'.
+ if (scalar @components > 2
+ && $components[0] ne ''
+ && defined $name2oid{$components[0]}) {
+ $name2oid{$components[0]}->{type} = 'arc';
+ }
+
+ return @numbers;
+}
+
+=item encode_oid()
+
+=cut
+
+# Forward declaration
+sub encode_oid_nums;
+sub encode_oid {
+ return encode_oid_nums parse_oid @_;
+}
+
+=item register_oid()
+
+=cut
+
+sub register_oid {
+ my $name = shift;
+ my @nums = parse_oid @_;
+
+ if (defined $name2oid{$name}) {
+ my $str1 = join(',', @nums);
+ my $str2 = join(',', @{$name2oid{$name}->{nums}});
+
+ croak "Invalid redefinition of $name with different value"
+ unless $str1 eq $str2;
+ } else {
+ $name2oid{$name} = { type => 'leaf', nums => [ @nums ] };
+ }
+}
+
+=item registered_oid_arcs()
+
+=item registered_oid_leaves()
+
+=cut
+
+sub _registered_oids {
+ my $type = shift;
+
+ return grep { $name2oid{$_}->{type} eq $type } keys %name2oid;
+}
+
+sub registered_oid_arcs {
+ return _registered_oids( 'arc' );
+}
+
+sub registered_oid_leaves {
+ return _registered_oids( 'leaf' );
+}
+
+=item encode_oid_nums()
+
+=cut
+
+# Internal helper. It takes a numeric OID component and generates the
+# DER encoding for it.
+sub _gen_oid_bytes {
+ my $num = shift;
+ my $cnt = 0;
+
+ return ( $num ) if $num < 128;
+ return ( ( map { $_ | 0x80 } _gen_oid_bytes($num >> 7) ), $num & 0x7f );
+}
+
+sub encode_oid_nums {
+ my @numbers = @_;
+
+ croak 'Invalid OID values: ( ', join(', ', @numbers), ' )'
+ if (scalar @numbers < 2
+ || $numbers[0] < 0 || $numbers[0] > 2
+ || $numbers[1] < 0 || $numbers[1] > 39);
+
+ my $first = shift(@numbers) * 40 + shift(@numbers);
+ @numbers = ( $first, map { _gen_oid_bytes($_) } @numbers );
+
+ return @numbers;
+}
+
+=back
+
+=head1 AUTHOR
+
+Richard levitte, C<< <richard at levitte.org> >>
+
+=cut
+
+######## Helpers
+
+sub _pairs (@) {
+ croak "Odd number of arguments" if @_ & 1;
+
+ my @pairlist = ();
+
+ while (@_) {
+ my $x = [ shift, shift ];
+ push @pairlist, $x;
+ }
+ return @pairlist;
+}
+
+sub _pairmap (&@) {
+ my $block = shift;
+ map { $block->($_) } _pairs @_;
+}
+
+1; # End of OpenSSL::OID
diff --git a/util/perl/OpenSSL/Ordinals.pm b/util/perl/OpenSSL/Ordinals.pm
new file mode 100644
index 000000000000..4d8c616b5b0a
--- /dev/null
+++ b/util/perl/OpenSSL/Ordinals.pm
@@ -0,0 +1,1087 @@
+#! /usr/bin/env perl
+# Copyright 2018-2023 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::Ordinals;
+
+use strict;
+use warnings;
+use Carp;
+use Scalar::Util qw(blessed);
+use OpenSSL::Util;
+
+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
+
+=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 => value >> pairs. Available
+options are:
+
+=over 4
+
+=item B<< from => 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 = {
+ filename => undef, # File name registered when loading
+ loaded_maxnum => 0, # Highest allocated item number when loading
+ loaded_contents => [], # Loaded items, if loading there was
+ maxassigned => 0, # Current highest assigned item number
+ 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'
+ debug => $opts{debug},
+ };
+ bless $instance, $class;
+
+ $instance->set_version($opts{version});
+ $instance->load($opts{from}) if defined($opts{from});
+
+ return $instance;
+}
+
+=item B<< $ordinals->load FILENAME >>
+
+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 "Undefined filename" unless defined($filename);
+
+ my @tmp_contents = ();
+ my %tmp_name2num = ();
+ my $max_assigned = 0;
+ 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(source => $filename, from => $_);
+
+ my $num = $item->number();
+ if ($num eq '?') {
+ $num = ++$max_num;
+ } elsif ($num eq '?+') {
+ $num = $max_num;
+ } else {
+ croak "Disordered ordinals, number sequence restarted"
+ if $max_num > $max_assigned && $num < $max_num;
+ croak "Disordered ordinals, $num < $max_num"
+ if $num < $max_num;
+ $max_assigned = $max_num = $num;
+ }
+
+ $item->intnum($num);
+ push @{$tmp_contents[$num]}, $item;
+ $tmp_name2num{$item->name()} = $num;
+ }
+ close F;
+
+ $self->{contents} = [ @tmp_contents ];
+ $self->{name2num} = { %tmp_name2num };
+ $self->{maxassigned} = $max_assigned;
+ $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->renumber >>
+
+Renumber any item that doesn't have an assigned number yet.
+
+=cut
+
+sub renumber {
+ my $self = shift;
+
+ my $max_assigned = 0;
+ foreach ($self->items(sort => by_number())) {
+ $_->number($_->intnum()) if $_->number() =~ m|^\?|;
+ if ($max_assigned < $_->number()) {
+ $max_assigned = $_->number();
+ }
+ }
+ $self->{maxassigned} = $max_assigned;
+}
+
+=item B<< $ordinals->rewrite >>
+
+=item B<< $ordinals->rewrite >>, I<%options>
+
+If an ordinals file has been loaded, it gets rewritten with the data from
+the current work database.
+
+If there are more arguments, they are used as I<%options> with the
+same semantics as for B<< $ordinals->items >> described below, apart
+from B<sort>, which is forbidden here.
+
+=cut
+
+sub rewrite {
+ my $self = shift;
+ my %opts = @_;
+
+ $self->write($self->{filename}, %opts);
+}
+
+=item B<< $ordinals->write FILENAME >>
+
+=item B<< $ordinals->write FILENAME >>, I<%options>
+
+Writes the current work database data to the ordinals file FILENAME.
+This also validates the data, see B<< $ordinals->validate >> below.
+
+If there are more arguments, they are used as I<%options> with the
+same semantics as for B<< $ordinals->items >> described next, apart
+from B<sort>, which is forbidden here.
+
+=cut
+
+sub write {
+ my $self = shift;
+ my $filename = shift;
+ my %opts = @_;
+
+ croak "Undefined filename" unless defined($filename);
+ croak "The 'sort' option is not allowed" if $opts{sort};
+
+ $self->validate();
+
+ open F, '>', $filename or croak "Unable to open $filename";
+ foreach ($self->items(%opts, sort => by_number())) {
+ print F $_->to_string(),"\n";
+ }
+ close F;
+ $self->{filename} = $filename;
+ $self->{loaded_maxnum} = $self->{maxnum};
+ return 1;
+}
+
+=item B<< $ordinals->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 => value >> pairs.
+Available options are:
+
+=over 4
+
+=item B<< sort => 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 => FILTERFUNCTION >>
+
+FILTERFUNCTION 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 = 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
+# - They MUST have the same version
+# - For platforms, both MUST hold the same ones, but with opposite values
+# - For features, both MUST hold the same ones.
+# - They MUST NOT have identical name, type, numeral, version, platforms, and features
+# 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, "\n ",
+ join("\n ", map { $_->{source}.": ".$_->name() } @items), "\n";
+ }
+ if (scalar @items == 2) {
+ # Collect some data
+ my %numbers = ();
+ my %versions = ();
+ my %features = ();
+ foreach (@items) {
+ $numbers{$_->intnum()} = 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()." => ".$_->intnum() } @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 for in addition identical name, type, and platforms
+ croak "Duplicate entries for ".$items[0]->name()." from ".
+ $items[0]->source()." and ".$items[1]->source()."\n"
+ if $items[0]->name() eq $items[1]->name()
+ && $items[0]->type() eq $items[1]->type()
+ && $items[0]->platforms() eq $items[1]->platforms();
+
+ # 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]->intnum()] = [ @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_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; }
+ }
+
+ return %features;
+}
+
+sub _adjust_version {
+ my $self = shift;
+ my $version = shift;
+ my $baseversion = $self->{baseversion};
+
+ $version = $baseversion
+ if ($baseversion ne '*' && $version ne '*'
+ && cmp_versions($baseversion, $version) > 0);
+
+ return $version;
+}
+
+=item B<< $ordinals->add SOURCE, NAME, TYPE, LIST >>
+
+Adds a new item from file SOURCE 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 '?' and the current default version.
+
+=cut
+
+sub add {
+ my $self = shift;
+ my $source = shift; # file where item was defined
+ 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 $intnum = @items ? $items[0]->intnum() : ++$self->{maxnum};
+ my $number = @items ? $items[0]->number() : '?';
+ 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( source => $source,
+ name => $name,
+ type => $type,
+ number => $number,
+ intnum => $intnum,
+ version =>
+ $self->_adjust_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($source, $alias->{name}, $name, @{$alias->{defs}})
+ if defined $alias;
+ return @returns;
+}
+
+=item B<< $ordinals->add_alias SOURCE, ALIAS, NAME, LIST >>
+
+Adds an alias ALIAS for the symbol NAME from file SOURCE, 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 $source = 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('$source' , '$alias' , '$name' , [ " . join(', ', @defs) . " ])";
+
+ croak "You're kidding me... $alias == $name" 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} = { source => $source,
+ 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 $number =
+ $items[0]->number() =~ m|^\?| ? '?+' : $items[0]->number();
+ my $alias_item = OpenSSL::Ordinals::Item->new(
+ source => $source,
+ name => $alias,
+ type => $items[0]->type(),
+ number => $number,
+ intnum => $items[0]->intnum(),
+ version => $self->_adjust_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->set_version VERSION >>
+
+=item B<< $ordinals->set_version VERSION BASEVERSION >>
+
+Sets the default version for new symbol to VERSION.
+
+If given, BASEVERSION sets the base version, i.e. the minimum version
+for all symbols. If not given, it will be calculated as follows:
+
+=over 4
+
+If the given version is '*', then the base version will also be '*'.
+
+If the given version starts with '0.', the base version will be '0.0.0'.
+
+If the given version starts with '1.0.', the base version will be '1.0.0'.
+
+If the given version starts with '1.1.', the base version will be '1.1.0'.
+
+If the given version has a first number C<N> that's greater than 1, the
+base version will be formed from C<N>: 'N.0.0'.
+
+=back
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ # '*' is for "we don't care"
+ my $version = shift // '*';
+ my $baseversion = shift // '*';
+
+ if ($baseversion eq '*') {
+ $baseversion = $version;
+ if ($baseversion ne '*') {
+ if ($baseversion =~ m|^(\d+)\.|, $1 > 1) {
+ $baseversion = "$1.0.0";
+ } else {
+ $baseversion =~ s|^0\..*$|0.0.0|;
+ $baseversion =~ s|^1\.0\..*$|1.0.0|;
+ $baseversion =~ s|^1\.1\..*$|1.1.0|;
+
+ die 'Invalid version'
+ if ($baseversion ne '0.0.0'
+ && $baseversion !~ m|^1\.[01]\.0$|);
+ }
+ }
+ }
+
+ die 'Invalid base version'
+ if ($baseversion ne '*' && $version ne '*'
+ && cmp_versions($baseversion, $version) > 0);
+
+ $self->{currversion} = $version;
+ $self->{baseversion} = $baseversion;
+ foreach ($self->items(filter => sub { $_[0] eq '*' })) {
+ $_->{version} = $self->{currversion};
+ }
+ return 1;
+}
+
+=item B<< $ordinals->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->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->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}++;
+ }
+ if ($i <= $self->{maxassigned}) {
+ $self->{stats}->{assigned}++;
+ } else {
+ $self->{stats}->{unassigned}++;
+ }
+ 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->stats >>
+
+Returns the statistics that B<validate> calculate.
+
+=cut
+
+sub stats {
+ my $self = shift;
+
+ return %{$self->{stats}};
+}
+
+=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 => value >> pairs.
+Available options are:
+
+=over 4
+
+=item B<< source => FILENAME >>, B<< from => STRING >>
+
+This will create a new item from FILENAME, 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)
+
+=item B<< source => FILENAME >>, B<< name => STRING >>, B<< number => NUMBER >>,
+ B<< version => STRING >>, B<< exists => BOOLEAN >>, B<< type => STRING >>,
+ B<< platforms => HASHref >>, B<< features => 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 = @_;
+
+ 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 = ( source => $opts{source},
+ 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] // '' ] );
+ }
+
+ if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
+ && ref($opts{platforms} // {}) eq 'HASH'
+ && ref($opts{features} // []) eq 'ARRAY') {
+ my $version = $opts{version};
+ $version =~ s|_|.|g;
+
+ $instance = { source => $opts{source},
+ name => $opts{name},
+ type => $opts{type},
+ number => $opts{number},
+ intnum => $opts{intnum},
+ version => $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;
+}
+
+sub DESTROY {
+}
+
+=item B<< $item->name >>
+
+The symbol name for this item.
+
+=item B<< $item->number >> (read-write)
+
+The positional number for this item.
+
+This may be '?' for an unassigned symbol, or '?+' for an unassigned symbol
+that's an alias for the previous symbol. '?' and '?+' must be properly
+handled by the caller. The caller may change this to an actual number.
+
+=item B<< $item->version >> (read-only)
+
+The version number for this item. Please note that these version numbers
+have underscore (C<_>) as a separator for the version parts.
+
+=item B<< $item->exists >> (read-only)
+
+A boolean that tells if this symbol exists in code or not.
+
+=item B<< $item->platforms >> (read-only)
+
+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->type >> (read-only)
+
+C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
+Some platforms do not care about this, others do.
+
+=item B<< $item->features >> (read-only)
+
+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->intnum >> (read-write)
+
+Internal positional number. If I<< $item->number >> is '?' or '?+', the
+caller can use this to set a number for its purposes.
+If I<< $item->number >> is a number, I<< $item->intnum >> should be the
+same
+
+=cut
+
+# Getter/setters
+sub intnum {
+ my $self = shift;
+ my $value = shift;
+ my $item = 'intnum';
+
+ croak "$item called with extra arguments" if @_;
+ $self->{$item} = "$value" if defined $value;
+ return $self->{$item};
+}
+
+sub number {
+ my $self = shift;
+ my $value = shift;
+ my $item = 'number';
+
+ croak "$item called with extra arguments" if @_;
+ $self->{$item} = "$value" if defined $value;
+ return $self->{$item};
+}
+
+=item B<< $item->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();
+ my $version = $self->version();
+ $version =~ s|\.|_|g;
+ return sprintf "%-39s %s\t%s\t%s:%s:%s:%s",
+ $self->name(),
+ $self->number(),
+ $version,
+ $self->exists() ? 'EXIST' : 'NOEXIST',
+ join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
+ sort keys %platforms)),
+ $self->type(),
+ join(',', @features);
+}
+
+=back
+
+=head2 Comparators and filters
+
+For the B<< $ordinals->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]->intnum() <=> $_[1]->intnum() };
+}
+
+=item B<by_version>
+
+Returns a comparator that will compare the version of two
+OpenSSL::Ordinals::Item objects.
+
+=cut
+
+sub by_version {
+ return sub {
+ # cmp_versions comes from OpenSSL::Util
+ return cmp_versions($_[0]->version(), $_[1]->version());
+ }
+}
+
+=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;
+
+ croak "No version specified"
+ unless $version && $version =~ /^\d+\.\d+\.\d+[a-z]{0,2}$/;
+
+ 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
+
+Richard Levitte E<lt>levitte@openssl.orgE<gt>.
+
+=cut
+
+1;
diff --git a/util/perl/OpenSSL/ParseC.pm b/util/perl/OpenSSL/ParseC.pm
new file mode 100644
index 000000000000..f98dd0e25e3b
--- /dev/null
+++ b/util/perl/OpenSSL/ParseC.pm
@@ -0,0 +1,1209 @@
+#! /usr/bin/env perl
+# Copyright 2018-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::ParseC;
+
+use strict;
+use warnings;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+$VERSION = "0.9";
+@ISA = qw(Exporter);
+@EXPORT = qw(parse);
+
+# Global handler data
+my @preprocessor_conds; # A list of simple preprocessor conditions,
+ # each item being a list of macros defined
+ # or not defined.
+
+# Handler helpers
+sub all_conds {
+ return map { ( @$_ ) } @preprocessor_conds;
+}
+
+# A list of handlers that will look at a "complete" string and try to
+# figure out what to make of it.
+# Each handler is a hash with the following keys:
+#
+# regexp a regexp to compare the "complete" string with.
+# checker a function that does a more complex comparison.
+# Use this instead of regexp if that isn't enough.
+# massager massages the "complete" string into an array with
+# the following elements:
+#
+# [0] String that needs further processing (this
+# applies to typedefs of structs), or empty.
+# [1] The name of what was found.
+# [2] A character that denotes what type of thing
+# this is: 'F' for function, 'S' for struct,
+# 'T' for typedef, 'M' for macro, 'V' for
+# variable.
+# [3] Return type (only for type 'F' and 'V')
+# [4] Value (for type 'M') or signature (for type 'F',
+# 'V', 'T' or 'S')
+# [5...] The list of preprocessor conditions this is
+# found in, as in checks for macro definitions
+# (stored as the macro's name) or the absence
+# of definition (stored as the macro's name
+# prefixed with a '!'
+#
+# If the massager returns an empty list, it means the
+# "complete" string has side effects but should otherwise
+# be ignored.
+# If the massager is undefined, the "complete" string
+# should be ignored.
+my @opensslcpphandlers = (
+ ##################################################################
+ # OpenSSL CPP specials
+ #
+ # These are used to convert certain pre-precessor expressions into
+ # others that @cpphandlers have a better chance to understand.
+
+ # This changes any OPENSSL_NO_DEPRECATED_x_y[_z] check to a check of
+ # OPENSSL_NO_DEPRECATEDIN_x_y[_z]. That's due to <openssl/macros.h>
+ # creating OPENSSL_NO_DEPRECATED_x_y[_z], but the ordinals files using
+ # DEPRECATEDIN_x_y[_z].
+ { regexp => qr/#if(def|ndef) OPENSSL_NO_DEPRECATED_(\d+_\d+(?:_\d+)?)$/,
+ massager => sub {
+ return (<<"EOF");
+#if$1 OPENSSL_NO_DEPRECATEDIN_$2
+EOF
+ }
+ }
+);
+my @cpphandlers = (
+ ##################################################################
+ # CPP stuff
+
+ { regexp => qr/#ifdef ?(.*)/,
+ massager => sub {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ push @preprocessor_conds, [ $1 ];
+ print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
+ if $opts{debug};
+ return ();
+ },
+ },
+ { regexp => qr/#ifndef ?(.*)/,
+ massager => sub {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ push @preprocessor_conds, [ '!'.$1 ];
+ print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
+ if $opts{debug};
+ return ();
+ },
+ },
+ { regexp => qr/#if (0|1)/,
+ massager => sub {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ if ($1 eq "1") {
+ push @preprocessor_conds, [ "TRUE" ];
+ } else {
+ push @preprocessor_conds, [ "!TRUE" ];
+ }
+ print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
+ if $opts{debug};
+ return ();
+ },
+ },
+ { regexp => qr/#if ?(.*)/,
+ massager => sub {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ my @results = ();
+ my $conds = $1;
+ if ($conds =~ m|^defined<<<\(([^\)]*)\)>>>(.*)$|) {
+ push @results, $1; # Handle the simple case
+ my $rest = $2;
+ my $re = qr/^(?:\|\|defined<<<\([^\)]*\)>>>)*$/;
+ print STDERR "DEBUG[",$opts{debug_type},"]: Matching '$rest' with '$re'\n"
+ if $opts{debug};
+ if ($rest =~ m/$re/) {
+ my @rest = split /\|\|/, $rest;
+ shift @rest;
+ foreach (@rest) {
+ m|^defined<<<\(([^\)]*)\)>>>$|;
+ die "Something wrong...$opts{PLACE}" if $1 eq "";
+ push @results, $1;
+ }
+ } else {
+ $conds =~ s/<<<|>>>//g;
+ warn "Warning: complicated #if expression(1): $conds$opts{PLACE}"
+ if $opts{warnings};
+ }
+ } elsif ($conds =~ m|^!defined<<<\(([^\)]*)\)>>>(.*)$|) {
+ push @results, '!'.$1; # Handle the simple case
+ my $rest = $2;
+ my $re = qr/^(?:\&\&!defined<<<\([^\)]*\)>>>)*$/;
+ print STDERR "DEBUG[",$opts{debug_type},"]: Matching '$rest' with '$re'\n"
+ if $opts{debug};
+ if ($rest =~ m/$re/) {
+ my @rest = split /\&\&/, $rest;
+ shift @rest;
+ foreach (@rest) {
+ m|^!defined<<<\(([^\)]*)\)>>>$|;
+ die "Something wrong...$opts{PLACE}" if $1 eq "";
+ push @results, '!'.$1;
+ }
+ } else {
+ $conds =~ s/<<<|>>>//g;
+ warn "Warning: complicated #if expression(2): $conds$opts{PLACE}"
+ if $opts{warnings};
+ }
+ } else {
+ $conds =~ s/<<<|>>>//g;
+ warn "Warning: complicated #if expression(3): $conds$opts{PLACE}"
+ if $opts{warnings};
+ }
+ print STDERR "DEBUG[",$opts{debug_type},"]: Added preprocessor conds: '", join("', '", @results), "'\n"
+ if $opts{debug};
+ push @preprocessor_conds, [ @results ];
+ print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
+ if $opts{debug};
+ return ();
+ },
+ },
+ { regexp => qr/#elif (.*)/,
+ massager => sub {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ die "An #elif without corresponding condition$opts{PLACE}"
+ if !@preprocessor_conds;
+ pop @preprocessor_conds;
+ print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
+ if $opts{debug};
+ return (<<"EOF");
+#if $1
+EOF
+ },
+ },
+ { regexp => qr/#else/,
+ massager => sub {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ die "An #else without corresponding condition$opts{PLACE}"
+ if !@preprocessor_conds;
+ # Invert all conditions on the last level
+ my $stuff = pop @preprocessor_conds;
+ push @preprocessor_conds, [
+ map { m|^!(.*)$| ? $1 : '!'.$_ } @$stuff
+ ];
+ print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
+ if $opts{debug};
+ return ();
+ },
+ },
+ { regexp => qr/#endif ?/,
+ massager => sub {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ die "An #endif without corresponding condition$opts{PLACE}"
+ if !@preprocessor_conds;
+ pop @preprocessor_conds;
+ print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
+ if $opts{debug};
+ return ();
+ },
+ },
+ { regexp => qr/#define ([[:alpha:]_]\w*)(<<<\(.*?\)>>>)?( (.*))?/,
+ massager => sub {
+ my $name = $1;
+ my $params = $2;
+ my $spaceval = $3||"";
+ my $val = $4||"";
+ return ("",
+ $1, 'M', "", $params ? "$name$params$spaceval" : $val,
+ all_conds()); }
+ },
+ { regexp => qr/#.*/,
+ massager => sub { return (); }
+ },
+ );
+
+my @opensslchandlers = (
+ ##################################################################
+ # OpenSSL C specials
+ #
+ # They are really preprocessor stuff, but they look like C stuff
+ # to this parser. All of these do replacements, anything else is
+ # an error.
+
+ #####
+ # Deprecated stuff, by OpenSSL release.
+
+ # OSSL_DEPRECATEDIN_x_y[_z] is simply ignored. Such declarations are
+ # supposed to be guarded with an '#ifdef OPENSSL_NO_DEPRECATED_x_y[_z]'
+ { regexp => qr/OSSL_DEPRECATEDIN_\d+_\d+(?:_\d+)?\s+(.*)/,
+ massager => sub { return $1; },
+ },
+ { regexp => qr/(.*?)\s+OSSL_DEPRECATEDIN_\d+_\d+(?:_\d+)?\s+(.*)/,
+ massager => sub { return "$1 $2"; },
+ },
+
+ #####
+ # Core stuff
+
+ # OSSL_CORE_MAKE_FUNC is a macro to create the necessary data and inline
+ # function the libcrypto<->provider interface
+ { regexp => qr/OSSL_CORE_MAKE_FUNC<<<\((.*?),(.*?),(.*?)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+typedef $1 OSSL_FUNC_$2_fn$3;
+static ossl_inline OSSL_FUNC_$2_fn *OSSL_FUNC_$2(const OSSL_DISPATCH *opf);
+EOF
+ },
+ },
+
+ #####
+ # LHASH stuff
+
+ # LHASH_OF(foo) is used as a type, but the chandlers won't take it
+ # gracefully, so we expand it here.
+ { regexp => qr/(.*)\bLHASH_OF<<<\((.*?)\)>>>(.*)/,
+ massager => sub { return ("$1struct lhash_st_$2$3"); }
+ },
+ { regexp => qr/DEFINE_LHASH_OF(?:_INTERNAL)?<<<\((.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+static ossl_inline LHASH_OF($1) * lh_$1_new(unsigned long (*hfn)(const $1 *),
+ int (*cfn)(const $1 *, const $1 *));
+static ossl_inline void lh_$1_free(LHASH_OF($1) *lh);
+static ossl_inline $1 *lh_$1_insert(LHASH_OF($1) *lh, $1 *d);
+static ossl_inline $1 *lh_$1_delete(LHASH_OF($1) *lh, const $1 *d);
+static ossl_inline $1 *lh_$1_retrieve(LHASH_OF($1) *lh, const $1 *d);
+static ossl_inline int lh_$1_error(LHASH_OF($1) *lh);
+static ossl_inline unsigned long lh_$1_num_items(LHASH_OF($1) *lh);
+static ossl_inline void lh_$1_node_stats_bio(const LHASH_OF($1) *lh, BIO *out);
+static ossl_inline void lh_$1_node_usage_stats_bio(const LHASH_OF($1) *lh,
+ BIO *out);
+static ossl_inline void lh_$1_stats_bio(const LHASH_OF($1) *lh, BIO *out);
+static ossl_inline unsigned long lh_$1_get_down_load(LHASH_OF($1) *lh);
+static ossl_inline void lh_$1_set_down_load(LHASH_OF($1) *lh, unsigned long dl);
+static ossl_inline void lh_$1_doall(LHASH_OF($1) *lh, void (*doall)($1 *));
+LHASH_OF($1)
+EOF
+ }
+ },
+
+ #####
+ # STACK stuff
+
+ # STACK_OF(foo) is used as a type, but the chandlers won't take it
+ # gracefully, so we expand it here.
+ { regexp => qr/(.*)\bSTACK_OF<<<\((.*?)\)>>>(.*)/,
+ massager => sub { return ("$1struct stack_st_$2$3"); }
+ },
+# { regexp => qr/(.*)\bSTACK_OF\((.*?)\)(.*)/,
+# massager => sub {
+# my $before = $1;
+# my $stack_of = "struct stack_st_$2";
+# my $after = $3;
+# if ($after =~ m|^\w|) { $after = " ".$after; }
+# return ("$before$stack_of$after");
+# }
+# },
+ { regexp => qr/SKM_DEFINE_STACK_OF<<<\((.*),\s*(.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+STACK_OF($1);
+typedef int (*sk_$1_compfunc)(const $3 * const *a, const $3 *const *b);
+typedef void (*sk_$1_freefunc)($3 *a);
+typedef $3 * (*sk_$1_copyfunc)(const $3 *a);
+static ossl_inline int sk_$1_num(const STACK_OF($1) *sk);
+static ossl_inline $2 *sk_$1_value(const STACK_OF($1) *sk, int idx);
+static ossl_inline STACK_OF($1) *sk_$1_new(sk_$1_compfunc compare);
+static ossl_inline STACK_OF($1) *sk_$1_new_null(void);
+static ossl_inline STACK_OF($1) *sk_$1_new_reserve(sk_$1_compfunc compare,
+ int n);
+static ossl_inline int sk_$1_reserve(STACK_OF($1) *sk, int n);
+static ossl_inline void sk_$1_free(STACK_OF($1) *sk);
+static ossl_inline void sk_$1_zero(STACK_OF($1) *sk);
+static ossl_inline $2 *sk_$1_delete(STACK_OF($1) *sk, int i);
+static ossl_inline $2 *sk_$1_delete_ptr(STACK_OF($1) *sk, $2 *ptr);
+static ossl_inline int sk_$1_push(STACK_OF($1) *sk, $2 *ptr);
+static ossl_inline int sk_$1_unshift(STACK_OF($1) *sk, $2 *ptr);
+static ossl_inline $2 *sk_$1_pop(STACK_OF($1) *sk);
+static ossl_inline $2 *sk_$1_shift(STACK_OF($1) *sk);
+static ossl_inline void sk_$1_pop_free(STACK_OF($1) *sk,
+ sk_$1_freefunc freefunc);
+static ossl_inline int sk_$1_insert(STACK_OF($1) *sk, $2 *ptr, int idx);
+static ossl_inline $2 *sk_$1_set(STACK_OF($1) *sk, int idx, $2 *ptr);
+static ossl_inline int sk_$1_find(STACK_OF($1) *sk, $2 *ptr);
+static ossl_inline int sk_$1_find_ex(STACK_OF($1) *sk, $2 *ptr);
+static ossl_inline void sk_$1_sort(STACK_OF($1) *sk);
+static ossl_inline int sk_$1_is_sorted(const STACK_OF($1) *sk);
+static ossl_inline STACK_OF($1) * sk_$1_dup(const STACK_OF($1) *sk);
+static ossl_inline STACK_OF($1) *sk_$1_deep_copy(const STACK_OF($1) *sk,
+ sk_$1_copyfunc copyfunc,
+ sk_$1_freefunc freefunc);
+static ossl_inline sk_$1_compfunc sk_$1_set_cmp_func(STACK_OF($1) *sk,
+ sk_$1_compfunc compare);
+EOF
+ }
+ },
+ { regexp => qr/SKM_DEFINE_STACK_OF_INTERNAL<<<\((.*),\s*(.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+STACK_OF($1);
+typedef int (*sk_$1_compfunc)(const $3 * const *a, const $3 *const *b);
+typedef void (*sk_$1_freefunc)($3 *a);
+typedef $3 * (*sk_$1_copyfunc)(const $3 *a);
+static ossl_unused ossl_inline $2 *ossl_check_$1_type($2 *ptr);
+static ossl_unused ossl_inline const OPENSSL_STACK *ossl_check_const_$1_sk_type(const STACK_OF($1) *sk);
+static ossl_unused ossl_inline OPENSSL_sk_compfunc ossl_check_$1_compfunc_type(sk_$1_compfunc cmp);
+static ossl_unused ossl_inline OPENSSL_sk_copyfunc ossl_check_$1_copyfunc_type(sk_$1_copyfunc cpy);
+static ossl_unused ossl_inline OPENSSL_sk_freefunc ossl_check_$1_freefunc_type(sk_$1_freefunc fr);
+EOF
+ }
+ },
+ { regexp => qr/DEFINE_SPECIAL_STACK_OF<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub { return ("SKM_DEFINE_STACK_OF($1,$2,$2)"); },
+ },
+ { regexp => qr/DEFINE_STACK_OF<<<\((.*)\)>>>/,
+ massager => sub { return ("SKM_DEFINE_STACK_OF($1,$1,$1)"); },
+ },
+ { regexp => qr/DEFINE_SPECIAL_STACK_OF_CONST<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub { return ("SKM_DEFINE_STACK_OF($1,const $2,$2)"); },
+ },
+ { regexp => qr/DEFINE_STACK_OF_CONST<<<\((.*)\)>>>/,
+ massager => sub { return ("SKM_DEFINE_STACK_OF($1,const $1,$1)"); },
+ },
+
+ #####
+ # ASN1 stuff
+ { regexp => qr/DECLARE_ASN1_ITEM<<<\((.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+const ASN1_ITEM *$1_it(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ENCODE_FUNCTIONS_only<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int d2i_$2(void);
+int i2d_$2(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ENCODE_FUNCTIONS<<<\((.*),\s*(.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int d2i_$3(void);
+int i2d_$3(void);
+DECLARE_ASN1_ITEM($2)
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ENCODE_FUNCTIONS_name<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int d2i_$2(void);
+int i2d_$2(void);
+DECLARE_ASN1_ITEM($2)
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ALLOC_FUNCTIONS_name<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int $2_free(void);
+int $2_new(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ALLOC_FUNCTIONS<<<\((.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int $1_free(void);
+int $1_new(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_FUNCTIONS_name<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int d2i_$2(void);
+int i2d_$2(void);
+int $2_free(void);
+int $2_new(void);
+DECLARE_ASN1_ITEM($2)
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_FUNCTIONS<<<\((.*)\)>>>/,
+ massager => sub { return (<<"EOF");
+int d2i_$1(void);
+int i2d_$1(void);
+int $1_free(void);
+int $1_new(void);
+DECLARE_ASN1_ITEM($1)
+EOF
+ }
+ },
+ { regexp => qr/DECLARE_ASN1_NDEF_FUNCTION<<<\((.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int i2d_$1_NDEF(void);
+EOF
+ }
+ },
+ { regexp => qr/DECLARE_ASN1_PRINT_FUNCTION<<<\((.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int $1_print_ctx(void);
+EOF
+ }
+ },
+ { regexp => qr/DECLARE_ASN1_PRINT_FUNCTION_name<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int $2_print_ctx(void);
+EOF
+ }
+ },
+ { regexp => qr/DECLARE_ASN1_SET_OF<<<\((.*)\)>>>/,
+ massager => sub { return (); }
+ },
+ { regexp => qr/DECLARE_ASN1_DUP_FUNCTION<<<\((.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int $1_dup(void);
+EOF
+ }
+ },
+ { regexp => qr/DECLARE_ASN1_DUP_FUNCTION_name<<<\((.*),\s*(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int $2_dup(void);
+EOF
+ }
+ },
+ # Universal translator of attributed PEM declarators
+ { regexp => qr/
+ DECLARE_ASN1
+ (_ENCODE_FUNCTIONS_only|_ENCODE_FUNCTIONS|_ENCODE_FUNCTIONS_name
+ |_ALLOC_FUNCTIONS_name|_ALLOC_FUNCTIONS|_FUNCTIONS_name|_FUNCTIONS
+ |_NDEF_FUNCTION|_PRINT_FUNCTION|_PRINT_FUNCTION_name
+ |_DUP_FUNCTION|_DUP_FUNCTION_name)
+ _attr
+ <<<\(\s*OSSL_DEPRECATEDIN_(.*?)\s*,(.*?)\)>>>
+ /x,
+ massager => sub { return (<<"EOF");
+DECLARE_ASN1$1($3)
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_PKCS12_SET_OF<<<\((.*)\)>>>/,
+ massager => sub { return (); }
+ },
+
+ #####
+ # PEM stuff
+ { regexp => qr/DECLARE_PEM(?|_rw|_rw_cb|_rw_const)<<<\((.*?),.*\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_NO_STDIO
+int PEM_read_$1(void);
+int PEM_write_$1(void);
+#endif
+int PEM_read_bio_$1(void);
+int PEM_write_bio_$1(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_PEM(?|_rw|_rw_cb|_rw_const)_ex<<<\((.*?),.*\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_NO_STDIO
+int PEM_read_$1(void);
+int PEM_write_$1(void);
+int PEM_read_$1_ex(void);
+int PEM_write_$1_ex(void);
+#endif
+int PEM_read_bio_$1(void);
+int PEM_write_bio_$1(void);
+int PEM_read_bio_$1_ex(void);
+int PEM_write_bio_$1_ex(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_PEM(?|_write|_write_cb|_write_const)<<<\((.*?),.*\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_NO_STDIO
+int PEM_write_$1(void);
+#endif
+int PEM_write_bio_$1(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_PEM(?|_write|_write_cb|_write_const)_ex<<<\((.*?),.*\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_NO_STDIO
+int PEM_write_$1(void);
+int PEM_write_$1_ex(void);
+#endif
+int PEM_write_bio_$1(void);
+int PEM_write_bio_$1_ex(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_PEM(?|_read|_read_cb)<<<\((.*?),.*\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_NO_STDIO
+int PEM_read_$1(void);
+#endif
+int PEM_read_bio_$1(void);
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_PEM(?|_read|_read_cb)_ex<<<\((.*?),.*\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_NO_STDIO
+int PEM_read_$1(void);
+int PEM_read_$1_ex(void);
+#endif
+int PEM_read_bio_$1(void);
+int PEM_read_bio_$1_ex(void);
+EOF
+ },
+ },
+ # Universal translator of attributed PEM declarators
+ { regexp => qr/
+ DECLARE_PEM
+ ((?:_rw|_rw_cb|_rw_const|_write|_write_cb|_write_const|_read|_read_cb)
+ (?:_ex)?)
+ _attr
+ <<<\(\s*OSSL_DEPRECATEDIN_(.*?)\s*,(.*?)\)>>>
+ /x,
+ massager => sub { return (<<"EOF");
+DECLARE_PEM$1($3)
+EOF
+ },
+ },
+
+ # OpenSSL's declaration of externs with possible export linkage
+ # (really only relevant on Windows)
+ { regexp => qr/OPENSSL_(?:EXPORT|EXTERN)/,
+ massager => sub { return ("extern"); }
+ },
+
+ # Spurious stuff found in the OpenSSL headers
+ # Usually, these are just macros that expand to, well, something
+ { regexp => qr/__NDK_FPABI__/,
+ massager => sub { return (); }
+ },
+ );
+
+my $anoncnt = 0;
+
+my @chandlers = (
+ ##################################################################
+ # C stuff
+
+ # extern "C" of individual items
+ # Note that the main parse function has a special hack for 'extern "C" {'
+ # which can't be done in handlers
+ # We simply ignore it.
+ { regexp => qr/^extern "C" (.*(?:;|>>>))/,
+ massager => sub { return ($1); },
+ },
+ # any other extern is just ignored
+ { regexp => qr/^\s* # Any spaces before
+ extern # The keyword we look for
+ \b # word to non-word boundary
+ .* # Anything after
+ ;
+ /x,
+ massager => sub { return (); },
+ },
+ # union, struct and enum definitions
+ # Because this one might appear a little everywhere within type
+ # definitions, we take it out and replace it with just
+ # 'union|struct|enum name' while registering it.
+ # This makes use of the parser trick to surround the outer braces
+ # with <<< and >>>
+ { regexp => qr/(.*) # Anything before ($1)
+ \b # word to non-word boundary
+ (union|struct|enum) # The word used ($2)
+ (?:\s([[:alpha:]_]\w*))? # Struct or enum name ($3)
+ <<<(\{.*?\})>>> # Struct or enum definition ($4)
+ (.*) # Anything after ($5)
+ ;
+ /x,
+ massager => sub {
+ my $before = $1;
+ my $word = $2;
+ my $name = $3
+ || sprintf("__anon%03d", ++$anoncnt); # Anonymous struct
+ my $definition = $4;
+ my $after = $5;
+ my $type = $word eq "struct" ? 'S' : 'E';
+ if ($before ne "" || $after ne ";") {
+ if ($after =~ m|^\w|) { $after = " ".$after; }
+ return ("$before$word $name$after;",
+ "$word $name", $type, "", "$word$definition", all_conds());
+ }
+ # If there was no before nor after, make the return much simple
+ return ("", "$word $name", $type, "", "$word$definition", all_conds());
+ }
+ },
+ # Named struct and enum forward declarations
+ # We really just ignore them, but we need to parse them or the variable
+ # declaration handler further down will think it's a variable declaration.
+ { regexp => qr/^(union|struct|enum) ([[:alpha:]_]\w*);/,
+ massager => sub { return (); }
+ },
+ # Function returning function pointer declaration
+ # This sort of declaration may have a body (inline functions, for example)
+ { regexp => qr/(?:(typedef)\s?)? # Possible typedef ($1)
+ ((?:\w|\*|\s)*?) # Return type ($2)
+ \s? # Possible space
+ <<<\(\*
+ ([[:alpha:]_]\w*) # Function name ($3)
+ (\(.*\)) # Parameters ($4)
+ \)>>>
+ <<<(\(.*\))>>> # F.p. parameters ($5)
+ (?:<<<\{.*\}>>>|;) # Body or semicolon
+ /x,
+ massager => sub {
+ return ("", $3, 'T', "", "$2(*$4)$5", all_conds())
+ if defined $1;
+ return ("", $3, 'F', "$2(*)$5", "$2(*$4)$5", all_conds()); }
+ },
+ # Function pointer declaration, or typedef thereof
+ # This sort of declaration never has a function body
+ { regexp => qr/(?:(typedef)\s?)? # Possible typedef ($1)
+ ((?:\w|\*|\s)*?) # Return type ($2)
+ <<<\(\*([[:alpha:]_]\w*)\)>>> # T.d. or var name ($3)
+ <<<(\(.*\))>>> # F.p. parameters ($4)
+ ;
+ /x,
+ massager => sub {
+ return ("", $3, 'T', "", "$2(*)$4", all_conds())
+ if defined $1;
+ return ("", $3, 'V', "$2(*)$4", "$2(*)$4", all_conds());
+ },
+ },
+ # Function declaration, or typedef thereof
+ # This sort of declaration may have a body (inline functions, for example)
+ { regexp => qr/(?:(typedef)\s?)? # Possible typedef ($1)
+ ((?:\w|\*|\s)*?) # Return type ($2)
+ \s? # Possible space
+ ([[:alpha:]_]\w*) # Function name ($3)
+ <<<(\(.*\))>>> # Parameters ($4)
+ (?:<<<\{.*\}>>>|;) # Body or semicolon
+ /x,
+ massager => sub {
+ return ("", $3, 'T', "", "$2$4", all_conds())
+ if defined $1;
+ return ("", $3, 'F', $2, "$2$4", all_conds());
+ },
+ },
+ # Variable declaration, including arrays, or typedef thereof
+ { regexp => qr/(?:(typedef)\s?)? # Possible typedef ($1)
+ ((?:\w|\*|\s)*?) # Type ($2)
+ \s? # Possible space
+ ([[:alpha:]_]\w*) # Variable name ($3)
+ ((?:<<<\[[^\]]*\]>>>)*) # Possible array declaration ($4)
+ ;
+ /x,
+ massager => sub {
+ return ("", $3, 'T', "", $2.($4||""), all_conds())
+ if defined $1;
+ return ("", $3, 'V', $2.($4||""), $2.($4||""), all_conds());
+ },
+ },
+);
+
+# End handlers are almost the same as handlers, except they are run through
+# ONCE when the input has been parsed through. These are used to check for
+# remaining stuff, such as an unfinished #ifdef and stuff like that that the
+# main parser can't check on its own.
+my @endhandlers = (
+ { massager => sub {
+ my %opts = %{$_[0]};
+
+ die "Unfinished preprocessor conditions levels: ",scalar(@preprocessor_conds),($opts{filename} ? " in file ".$opts{filename}: ""),$opts{PLACE}
+ if @preprocessor_conds;
+ }
+ }
+ );
+
+# takes a list of strings that can each contain one or several lines of code
+# also takes a hash of options as last argument.
+#
+# returns a list of hashes with information:
+#
+# name name of the thing
+# type type, see the massage handler function
+# returntype return type of functions and variables
+# value value for macros, signature for functions, variables
+# and structs
+# conds preprocessor conditions (array ref)
+
+sub parse {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ my %state = (
+ in_extern_C => 0, # An exception to parenthesis processing.
+ cpp_parens => [], # A list of ending parens and braces found in
+ # preprocessor directives
+ c_parens => [], # A list of ending parens and braces found in
+ # C statements
+ in_string => "", # empty string when outside a string, otherwise
+ # "'" or '"' depending on the starting quote.
+ in_comment => "", # empty string when outside a comment, otherwise
+ # "/*" or "//" depending on the type of comment
+ # found. The latter will never be multiline
+ # NOTE: in_string and in_comment will never be
+ # true (in perl semantics) at the same time.
+ current_line => 0,
+ );
+ my @result = ();
+ my $normalized_line = ""; # $input_line, but normalized. In essence, this
+ # means that ALL whitespace is removed unless
+ # it absolutely has to be present, and in that
+ # case, there's only one space.
+ # The cases where a space needs to stay present
+ # are:
+ # 1. between words
+ # 2. between words and number
+ # 3. after the first word of a preprocessor
+ # directive.
+ # 4. for the #define directive, between the macro
+ # name/args and its value, so we end up with:
+ # #define FOO val
+ # #define BAR(x) something(x)
+ my $collected_stmt = ""; # Where we're building up a C line until it's a
+ # complete definition/declaration, as determined
+ # by any handler being capable of matching it.
+
+ # We use $_ shamelessly when looking through @lines.
+ # In case we find a \ at the end, we keep filling it up with more lines.
+ $_ = undef;
+
+ foreach my $line (@_) {
+ # split tries to be smart when a string ends with the thing we split on
+ $line .= "\n" unless $line =~ m|\R$|;
+ $line .= "#";
+
+ # We use ¦undef¦ as a marker for a new line from the file.
+ # Since we convert one line to several and unshift that into @lines,
+ # that's the only safe way we have to track the original lines
+ my @lines = map { ( undef, $_ ) } split m|\R|, $line;
+
+ # Remember that extra # we added above? Now we remove it
+ pop @lines;
+ pop @lines; # Don't forget the undef
+
+ while (@lines) {
+ if (!defined($lines[0])) {
+ shift @lines;
+ $state{current_line}++;
+ if (!defined($_)) {
+ $opts{PLACE} = " at ".$opts{filename}." line ".$state{current_line}."\n";
+ $opts{PLACE2} = $opts{filename}.":".$state{current_line};
+ }
+ next;
+ }
+
+ $_ = "" unless defined $_;
+ $_ .= shift @lines;
+
+ if (m|\\$|) {
+ $_ = $`;
+ next;
+ }
+
+ if ($opts{debug}) {
+ print STDERR "DEBUG:----------------------------\n";
+ print STDERR "DEBUG: \$_ = '$_'\n";
+ }
+
+ ##########################################################
+ # Now that we have a full line, let's process through it
+ while(1) {
+ unless ($state{in_comment}) {
+ # Begin with checking if the current $normalized_line
+ # contains a preprocessor directive
+ # This is only done if we're not inside a comment and
+ # if it's a preprocessor directive and it's finished.
+ if ($normalized_line =~ m|^#| && $_ eq "") {
+ print STDERR "DEBUG[OPENSSL CPP]: \$normalized_line = '$normalized_line'\n"
+ if $opts{debug};
+ $opts{debug_type} = "OPENSSL CPP";
+ my @r = ( _run_handlers($normalized_line,
+ @opensslcpphandlers,
+ \%opts) );
+ if (shift @r) {
+ # Checking if there are lines to inject.
+ if (@r) {
+ @r = split $/, (pop @r).$_;
+ print STDERR "DEBUG[OPENSSL CPP]: injecting '", join("', '", @r),"'\n"
+ if $opts{debug} && @r;
+ @lines = ( @r, @lines );
+
+ $_ = "";
+ }
+ } else {
+ print STDERR "DEBUG[CPP]: \$normalized_line = '$normalized_line'\n"
+ if $opts{debug};
+ $opts{debug_type} = "CPP";
+ my @r = ( _run_handlers($normalized_line,
+ @cpphandlers,
+ \%opts) );
+ if (shift @r) {
+ if (ref($r[0]) eq "HASH") {
+ push @result, shift @r;
+ }
+
+ # Now, check if there are lines to inject.
+ # Really, this should never happen, it IS a
+ # preprocessor directive after all...
+ if (@r) {
+ @r = split $/, pop @r;
+ print STDERR "DEBUG[CPP]: injecting '", join("', '", @r),"'\n"
+ if $opts{debug} && @r;
+ @lines = ( @r, @lines );
+ $_ = "";
+ }
+ }
+ }
+
+ # Note: we simply ignore all directives that no
+ # handler matches
+ $normalized_line = "";
+ }
+
+ # If the two strings end and start with a character that
+ # shouldn't get concatenated, add a space
+ my $space =
+ ($collected_stmt =~ m/(?:"|')$/
+ || ($collected_stmt =~ m/(?:\w|\d)$/
+ && $normalized_line =~ m/^(?:\w|\d)/)) ? " " : "";
+
+ # Now, unless we're building up a preprocessor directive or
+ # are in the middle of a string, or the parens et al aren't
+ # balanced up yet, let's try and see if there's a OpenSSL
+ # or C handler that can make sense of what we have so far.
+ if ( $normalized_line !~ m|^#|
+ && ($collected_stmt ne "" || $normalized_line ne "")
+ && ! @{$state{c_parens}}
+ && ! $state{in_string} ) {
+ if ($opts{debug}) {
+ print STDERR "DEBUG[OPENSSL C]: \$collected_stmt = '$collected_stmt'\n";
+ print STDERR "DEBUG[OPENSSL C]: \$normalized_line = '$normalized_line'\n";
+ }
+ $opts{debug_type} = "OPENSSL C";
+ my @r = ( _run_handlers($collected_stmt
+ .$space
+ .$normalized_line,
+ @opensslchandlers,
+ \%opts) );
+ if (shift @r) {
+ # Checking if there are lines to inject.
+ if (@r) {
+ @r = split $/, (pop @r).$_;
+ print STDERR "DEBUG[OPENSSL]: injecting '", join("', '", @r),"'\n"
+ if $opts{debug} && @r;
+ @lines = ( @r, @lines );
+
+ $_ = "";
+ }
+ $normalized_line = "";
+ $collected_stmt = "";
+ } else {
+ if ($opts{debug}) {
+ print STDERR "DEBUG[C]: \$collected_stmt = '$collected_stmt'\n";
+ print STDERR "DEBUG[C]: \$normalized_line = '$normalized_line'\n";
+ }
+ $opts{debug_type} = "C";
+ my @r = ( _run_handlers($collected_stmt
+ .$space
+ .$normalized_line,
+ @chandlers,
+ \%opts) );
+ if (shift @r) {
+ if (ref($r[0]) eq "HASH") {
+ push @result, shift @r;
+ }
+
+ # Checking if there are lines to inject.
+ if (@r) {
+ @r = split $/, (pop @r).$_;
+ print STDERR "DEBUG[C]: injecting '", join("', '", @r),"'\n"
+ if $opts{debug} && @r;
+ @lines = ( @r, @lines );
+
+ $_ = "";
+ }
+ $normalized_line = "";
+ $collected_stmt = "";
+ }
+ }
+ }
+ if ($_ eq "") {
+ $collected_stmt .= $space.$normalized_line;
+ $normalized_line = "";
+ }
+ }
+
+ if ($_ eq "") {
+ $_ = undef;
+ last;
+ }
+
+ # Take care of inside string first.
+ if ($state{in_string}) {
+ if (m/ (?:^|(?<!\\)) # Make sure it's not escaped
+ $state{in_string} # Look for matching quote
+ /x) {
+ $normalized_line .= $`.$&;
+ $state{in_string} = "";
+ $_ = $';
+ next;
+ } else {
+ die "Unfinished string without continuation found$opts{PLACE}\n";
+ }
+ }
+ # ... or inside comments, whichever happens to apply
+ elsif ($state{in_comment}) {
+
+ # This should never happen
+ die "Something went seriously wrong, multiline //???$opts{PLACE}\n"
+ if ($state{in_comment} eq "//");
+
+ # A note: comments are simply discarded.
+
+ if (m/ (?:^|(?<!\\)) # Make sure it's not escaped
+ \*\/ # Look for C comment end
+ /x) {
+ $state{in_comment} = "";
+ $_ = $';
+ print STDERR "DEBUG: Found end of comment, followed by '$_'\n"
+ if $opts{debug};
+ next;
+ } else {
+ $_ = "";
+ next;
+ }
+ }
+
+ # At this point, it's safe to remove leading whites, but
+ # we need to be careful with some preprocessor lines
+ if (m|^\s+|) {
+ my $rest = $';
+ my $space = "";
+ $space = " "
+ if ($normalized_line =~ m/^
+ \#define\s\w(?:\w|\d)*(?:<<<\([^\)]*\)>>>)?
+ | \#[a-z]+
+ $/x);
+ print STDERR "DEBUG: Processing leading spaces: \$normalized_line = '$normalized_line', \$space = '$space', \$rest = '$rest'\n"
+ if $opts{debug};
+ $_ = $space.$rest;
+ }
+
+ my $parens =
+ $normalized_line =~ m|^#| ? 'cpp_parens' : 'c_parens';
+ (my $paren_singular = $parens) =~ s|s$||;
+
+ # Now check for specific tokens, and if they are parens,
+ # check them against $state{$parens}. Note that we surround
+ # the outermost parens with extra "<<<" and ">>>". Those
+ # are for the benefit of handlers who to need to detect
+ # them, and they will be removed from the final output.
+ if (m|^[\{\[\(]|) {
+ my $body = $&;
+ $_ = $';
+ if (!@{$state{$parens}}) {
+ if ("$normalized_line$body" =~ m|^extern "C"\{$|) {
+ $state{in_extern_C} = 1;
+ print STDERR "DEBUG: found start of 'extern \"C\"' ($normalized_line$body)\n"
+ if $opts{debug};
+ $normalized_line = "";
+ } else {
+ $normalized_line .= "<<<".$body;
+ }
+ } else {
+ $normalized_line .= $body;
+ }
+
+ if ($normalized_line ne "") {
+ print STDERR "DEBUG: found $paren_singular start '$body'\n"
+ if $opts{debug};
+ $body =~ tr|\{\[\(|\}\]\)|;
+ print STDERR "DEBUG: pushing $paren_singular end '$body'\n"
+ if $opts{debug};
+ push @{$state{$parens}}, $body;
+ }
+ } elsif (m|^[\}\]\)]|) {
+ $_ = $';
+
+ if (!@{$state{$parens}}
+ && $& eq '}' && $state{in_extern_C}) {
+ print STDERR "DEBUG: found end of 'extern \"C\"'\n"
+ if $opts{debug};
+ $state{in_extern_C} = 0;
+ } else {
+ print STDERR "DEBUG: Trying to match '$&' against '"
+ ,join("', '", @{$state{$parens}})
+ ,"'\n"
+ if $opts{debug};
+ die "Unmatched parentheses$opts{PLACE}\n"
+ unless (@{$state{$parens}}
+ && pop @{$state{$parens}} eq $&);
+ if (!@{$state{$parens}}) {
+ $normalized_line .= $&.">>>";
+ } else {
+ $normalized_line .= $&;
+ }
+ }
+ } elsif (m|^["']|) { # string start
+ my $body = $&;
+ $_ = $';
+
+ # We want to separate strings from \w and \d with one space.
+ $normalized_line .= " " if $normalized_line =~ m/(\w|\d)$/;
+ $normalized_line .= $body;
+ $state{in_string} = $body;
+ } elsif (m|^\/\*|) { # C style comment
+ print STDERR "DEBUG: found start of C style comment\n"
+ if $opts{debug};
+ $state{in_comment} = $&;
+ $_ = $';
+ } elsif (m|^\/\/|) { # C++ style comment
+ print STDERR "DEBUG: found C++ style comment\n"
+ if $opts{debug};
+ $_ = ""; # (just discard it entirely)
+ } elsif (m/^ (?| (?: 0[xX][[:xdigit:]]+ | 0[bB][01]+ | [0-9]+ )
+ (?i: U | L | UL | LL | ULL )?
+ | [0-9]+\.[0-9]+(?:[eE][\-\+]\d+)? (?i: F | L)?
+ ) /x) {
+ print STDERR "DEBUG: Processing numbers: \$normalized_line = '$normalized_line', \$& = '$&', \$' = '$''\n"
+ if $opts{debug};
+ $normalized_line .= $&;
+ $_ = $';
+ } elsif (m/^[[:alpha:]_]\w*/) {
+ my $body = $&;
+ my $rest = $';
+ my $space = "";
+
+ # Now, only add a space if it's needed to separate
+ # two \w characters, and we also surround strings with
+ # a space. In this case, that's if $normalized_line ends
+ # with a \w, \d, " or '.
+ $space = " "
+ if ($normalized_line =~ m/("|')$/
+ || ($normalized_line =~ m/(\w|\d)$/
+ && $body =~ m/^(\w|\d)/));
+
+ print STDERR "DEBUG: Processing words: \$normalized_line = '$normalized_line', \$space = '$space', \$body = '$body', \$rest = '$rest'\n"
+ if $opts{debug};
+ $normalized_line .= $space.$body;
+ $_ = $rest;
+ } elsif (m|^(?:\\)?.|) { # Catch-all
+ $normalized_line .= $&;
+ $_ = $';
+ }
+ }
+ }
+ }
+ foreach my $handler (@endhandlers) {
+ if ($handler->{massager}) {
+ $handler->{massager}->(\%opts);
+ }
+ }
+ return @result;
+}
+
+# arg1: line to check
+# arg2...: handlers to check
+# return undef when no handler matched
+sub _run_handlers {
+ my %opts;
+ if (ref($_[$#_]) eq "HASH") {
+ %opts = %{$_[$#_]};
+ pop @_;
+ }
+ my $line = shift;
+ my @handlers = @_;
+
+ foreach my $handler (@handlers) {
+ if ($handler->{regexp}
+ && $line =~ m|^$handler->{regexp}$|) {
+ if ($handler->{massager}) {
+ if ($opts{debug}) {
+ print STDERR "DEBUG[",$opts{debug_type},"]: Trying to handle '$line'\n";
+ print STDERR "DEBUG[",$opts{debug_type},"]: (matches /\^",$handler->{regexp},"\$/)\n";
+ }
+ my $saved_line = $line;
+ my @massaged =
+ map { s/(<<<|>>>)//g; $_ }
+ $handler->{massager}->($saved_line, \%opts);
+ print STDERR "DEBUG[",$opts{debug_type},"]: Got back '"
+ , join("', '", @massaged), "'\n"
+ if $opts{debug};
+
+ # Because we may get back new lines to be
+ # injected before whatever else that follows,
+ # and the injected stuff might include
+ # preprocessor lines, we need to inject them
+ # in @lines and set $_ to the empty string to
+ # break out from the inner loops
+ my $injected_lines = shift @massaged || "";
+
+ if (@massaged) {
+ return (1,
+ {
+ name => shift @massaged,
+ type => shift @massaged,
+ returntype => shift @massaged,
+ value => shift @massaged,
+ conds => [ @massaged ]
+ },
+ $injected_lines
+ );
+ } else {
+ print STDERR "DEBUG[",$opts{debug_type},"]: (ignore, possible side effects)\n"
+ if $opts{debug} && $injected_lines eq "";
+ return (1, $injected_lines);
+ }
+ }
+ return (1);
+ }
+ }
+ return (0);
+}
diff --git a/util/perl/OpenSSL/Template.pm b/util/perl/OpenSSL/Template.pm
new file mode 100644
index 000000000000..7411dd8ae8d7
--- /dev/null
+++ b/util/perl/OpenSSL/Template.pm
@@ -0,0 +1,150 @@
+#! /usr/bin/env perl
+# Copyright 2016-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
+
+# Implements the functionality to read one or more template files and run
+# them through Text::Template
+
+package OpenSSL::Template;
+
+=head1 NAME
+
+OpenSSL::Template - a private extension of Text::Template
+
+=head1 DESCRIPTION
+
+This provides exactly the functionality from Text::Template, with the
+following additions:
+
+=over 4
+
+=item *
+
+The template perl code delimiters (given with the C<DELIMITER> option)
+are set to C<{-> and C<-}> by default.
+
+=item *
+
+A few extra functions are offered to be used by the template perl code, see
+L</Functions>.
+
+=back
+
+=cut
+
+use File::Basename;
+use File::Spec::Functions;
+use Text::Template 1.46;
+
+our @ISA = qw(Text::Template); # parent
+
+sub new {
+ my $class = shift;
+
+ # Call the constructor of the parent class.
+ my $self = $class->SUPER::new(DELIMITERS => [ '{-', '-}'],
+ @_ );
+
+ # Add few more attributes
+ $self->{_output_off} = 0; # Default to output hunks
+
+ return bless $self, $class;
+}
+
+sub fill_in {
+ my $self = shift;
+ my %opts = @_;
+ my %hash = ( %{$opts{HASH}} );
+ delete $opts{HASH};
+
+ $self->SUPER::fill_in(HASH => { quotify1 => \&quotify1,
+ quotify_l => \&quotify_l,
+ output_on => sub { $self->output_on() },
+ output_off => sub { $self->output_off() },
+ %hash },
+ %opts);
+}
+
+=head2 Functions
+
+=cut
+
+# Override Text::Template's append_text_to_result, as recommended here:
+#
+# http://search.cpan.org/~mjd/Text-Template-1.46/lib/Text/Template.pm#Automatic_postprocessing_of_template_hunks
+sub append_text_to_output {
+ my $self = shift;
+
+ if ($self->{_output_off} == 0) {
+ $self->SUPER::append_text_to_output(@_);
+ }
+
+ return;
+}
+
+=begin comment
+
+We lie about the OO nature of output_on() and output_off(), 'cause that's
+not how we pass them, see the HASH option used in fill_in() above
+
+=end comment
+
+=over 4
+
+=item output_on()
+
+=item output_off()
+
+Switch on or off template output. Here's an example usage:
+
+=over 4
+
+ {- output_off() if CONDITION -}
+ whatever
+ {- output_on() if CONDITION -}
+
+=back
+
+In this example, C<whatever> will only become part of the template output
+if C<CONDITION> is true.
+
+=back
+
+=cut
+
+sub output_on {
+ my $self = shift;
+ if (--$self->{_output_off} < 0) {
+ $self->{_output_off} = 0;
+ }
+}
+
+sub output_off {
+ my $self = shift;
+ $self->{_output_off}++;
+}
+
+# Helper functions for the templates #################################
+
+=head1 SEE ALSO
+
+L<Text::Template>
+
+=head1 AUTHORS
+
+Richard Levitte E<lt>levitte@openssl.orgE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2016-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
+L<https://www.openssl.org/source/license.html>.
+
+=cut
diff --git a/util/perl/OpenSSL/Test.pm b/util/perl/OpenSSL/Test.pm
new file mode 100644
index 000000000000..00ef1832d3a0
--- /dev/null
+++ b/util/perl/OpenSSL/Test.pm
@@ -0,0 +1,1301 @@
+# Copyright 2016-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::Test;
+
+use strict;
+use warnings;
+
+use Test::More 0.96;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+$VERSION = "1.0";
+@ISA = qw(Exporter);
+@EXPORT = (@Test::More::EXPORT, qw(setup run indir cmd app fuzz test
+ perlapp perltest subtest));
+@EXPORT_OK = (@Test::More::EXPORT_OK, qw(bldtop_dir bldtop_file
+ srctop_dir srctop_file
+ data_file data_dir
+ result_file result_dir
+ pipe with cmdstr
+ openssl_versions
+ ok_nofips is_nofips isnt_nofips));
+
+=head1 NAME
+
+OpenSSL::Test - a private extension of Test::More
+
+=head1 SYNOPSIS
+
+ use OpenSSL::Test;
+
+ setup("my_test_name");
+
+ plan tests => 2;
+
+ ok(run(app(["openssl", "version"])), "check for openssl presence");
+
+ indir "subdir" => sub {
+ ok(run(test(["sometest", "arg1"], stdout => "foo.txt")),
+ "run sometest with output to foo.txt");
+ };
+
+=head1 DESCRIPTION
+
+This module is a private extension of L<Test::More> for testing OpenSSL.
+In addition to the Test::More functions, it also provides functions that
+easily find the diverse programs within a OpenSSL build tree, as well as
+some other useful functions.
+
+This module I<depends> on the environment variables C<$TOP> or C<$SRCTOP>
+and C<$BLDTOP>. Without one of the combinations it refuses to work.
+See L</ENVIRONMENT> below.
+
+With each test recipe, a parallel data directory with (almost) the same name
+as the recipe is possible in the source directory tree. For example, for a
+recipe C<$SRCTOP/test/recipes/99-foo.t>, there could be a directory
+C<$SRCTOP/test/recipes/99-foo_data/>.
+
+=cut
+
+use File::Copy;
+use File::Spec::Functions qw/file_name_is_absolute curdir canonpath splitdir
+ catdir catfile splitpath catpath devnull abs2rel/;
+use File::Path 2.00 qw/rmtree mkpath/;
+use File::Basename;
+use Cwd qw/getcwd abs_path/;
+use OpenSSL::Util;
+
+my $level = 0;
+
+# The name of the test. This is set by setup() and is used in the other
+# functions to verify that setup() has been used.
+my $test_name = undef;
+
+# Directories we want to keep track of TOP, APPS, TEST and RESULTS are the
+# ones we're interested in, corresponding to the environment variables TOP
+# (mandatory), BIN_D, TEST_D, UTIL_D and RESULT_D.
+my %directories = ();
+
+# The environment variables that gave us the contents in %directories. These
+# get modified whenever we change directories, so that subprocesses can use
+# the values of those environment variables as well
+my @direnv = ();
+
+# A bool saying if we shall stop all testing if the current recipe has failing
+# tests or not. This is set by setup() if the environment variable STOPTEST
+# is defined with a non-empty value.
+my $end_with_bailout = 0;
+
+# A set of hooks that is affected by with() and may be used in diverse places.
+# All hooks are expected to be CODE references.
+my %hooks = (
+
+ # exit_checker is used by run() directly after completion of a command.
+ # it receives the exit code from that command and is expected to return
+ # 1 (for success) or 0 (for failure). This is the status value that run()
+ # will give back (through the |statusvar| reference and as returned value
+ # when capture => 1 doesn't apply).
+ exit_checker => sub { return shift == 0 ? 1 : 0 },
+
+ );
+
+# Debug flag, to be set manually when needed
+my $debug = 0;
+
+=head2 Main functions
+
+The following functions are exported by default when using C<OpenSSL::Test>.
+
+=cut
+
+=over 4
+
+=item B<setup "NAME">
+
+C<setup> is used for initial setup, and it is mandatory that it's used.
+If it's not used in a OpenSSL test recipe, the rest of the recipe will
+most likely refuse to run.
+
+C<setup> checks for environment variables (see L</ENVIRONMENT> below),
+checks that C<$TOP/Configure> or C<$SRCTOP/Configure> exists, C<chdir>
+into the results directory (defined by the C<$RESULT_D> environment
+variable if defined, otherwise C<$BLDTOP/test-runs> or C<$TOP/test-runs>,
+whichever is defined).
+
+=back
+
+=cut
+
+sub setup {
+ my $old_test_name = $test_name;
+ $test_name = shift;
+ my %opts = @_;
+
+ BAIL_OUT("setup() must receive a name") unless $test_name;
+ warn "setup() detected test name change. Innocuous, so we continue...\n"
+ if $old_test_name && $old_test_name ne $test_name;
+
+ return if $old_test_name;
+
+ BAIL_OUT("setup() needs \$TOP or \$SRCTOP and \$BLDTOP to be defined")
+ unless $ENV{TOP} || ($ENV{SRCTOP} && $ENV{BLDTOP});
+ BAIL_OUT("setup() found both \$TOP and \$SRCTOP or \$BLDTOP...")
+ if $ENV{TOP} && ($ENV{SRCTOP} || $ENV{BLDTOP});
+
+ __env();
+
+ BAIL_OUT("setup() expects the file Configure in the source top directory")
+ unless -f srctop_file("Configure");
+
+ note "The results of this test will end up in $directories{RESULTS}"
+ unless $opts{quiet};
+
+ __cwd($directories{RESULTS});
+}
+
+=over 4
+
+=item B<indir "SUBDIR" =E<gt> sub BLOCK, OPTS>
+
+C<indir> is used to run a part of the recipe in a different directory than
+the one C<setup> moved into, usually a subdirectory, given by SUBDIR.
+The part of the recipe that's run there is given by the codeblock BLOCK.
+
+C<indir> takes some additional options OPTS that affect the subdirectory:
+
+=over 4
+
+=item B<create =E<gt> 0|1>
+
+When set to 1 (or any value that perl perceives as true), the subdirectory
+will be created if it doesn't already exist. This happens before BLOCK
+is executed.
+
+=back
+
+An example:
+
+ indir "foo" => sub {
+ ok(run(app(["openssl", "version"]), stdout => "foo.txt"));
+ if (ok(open(RESULT, "foo.txt"), "reading foo.txt")) {
+ my $line = <RESULT>;
+ close RESULT;
+ is($line, qr/^OpenSSL 1\./,
+ "check that we're using OpenSSL 1.x.x");
+ }
+ }, create => 1;
+
+=back
+
+=cut
+
+sub indir {
+ my $subdir = shift;
+ my $codeblock = shift;
+ my %opts = @_;
+
+ my $reverse = __cwd($subdir,%opts);
+ BAIL_OUT("FAILURE: indir, \"$subdir\" wasn't possible to move into")
+ unless $reverse;
+
+ $codeblock->();
+
+ __cwd($reverse);
+}
+
+=over 4
+
+=item B<cmd ARRAYREF, OPTS>
+
+This functions build up a platform dependent command based on the
+input. It takes a reference to a list that is the executable or
+script and its arguments, and some additional options (described
+further on). Where necessary, the command will be wrapped in a
+suitable environment to make sure the correct shared libraries are
+used (currently only on Unix).
+
+It returns a CODEREF to be used by C<run>, C<pipe> or C<cmdstr>.
+
+The options that C<cmd> (as well as its derivatives described below) can take
+are in the form of hash values:
+
+=over 4
+
+=item B<stdin =E<gt> PATH>
+
+=item B<stdout =E<gt> PATH>
+
+=item B<stderr =E<gt> PATH>
+
+In all three cases, the corresponding standard input, output or error is
+redirected from (for stdin) or to (for the others) a file given by the
+string PATH, I<or>, if the value is C<undef>, C</dev/null> or similar.
+
+=back
+
+=item B<app ARRAYREF, OPTS>
+
+=item B<test ARRAYREF, OPTS>
+
+Both of these are specific applications of C<cmd>, with just a couple
+of small difference:
+
+C<app> expects to find the given command (the first item in the given list
+reference) as an executable in C<$BIN_D> (if defined, otherwise C<$TOP/apps>
+or C<$BLDTOP/apps>).
+
+C<test> expects to find the given command (the first item in the given list
+reference) as an executable in C<$TEST_D> (if defined, otherwise C<$TOP/test>
+or C<$BLDTOP/test>).
+
+Also, for both C<app> and C<test>, the command may be prefixed with
+the content of the environment variable C<$EXE_SHELL>, which is useful
+in case OpenSSL has been cross compiled.
+
+=item B<perlapp ARRAYREF, OPTS>
+
+=item B<perltest ARRAYREF, OPTS>
+
+These are also specific applications of C<cmd>, where the interpreter
+is predefined to be C<perl>, and they expect the script to be
+interpreted to reside in the same location as C<app> and C<test>.
+
+C<perlapp> and C<perltest> will also take the following option:
+
+=over 4
+
+=item B<interpreter_args =E<gt> ARRAYref>
+
+The array reference is a set of arguments for the interpreter rather
+than the script. Take care so that none of them can be seen as a
+script! Flags and their eventual arguments only!
+
+=back
+
+An example:
+
+ ok(run(perlapp(["foo.pl", "arg1"],
+ interpreter_args => [ "-I", srctop_dir("test") ])));
+
+=back
+
+=begin comment
+
+One might wonder over the complexity of C<apps>, C<fuzz>, C<test>, ...
+with all the lazy evaluations and all that. The reason for this is that
+we want to make sure the directory in which those programs are found are
+correct at the time these commands are used. Consider the following code
+snippet:
+
+ my $cmd = app(["openssl", ...]);
+
+ indir "foo", sub {
+ ok(run($cmd), "Testing foo")
+ };
+
+If there wasn't this lazy evaluation, the directory where C<openssl> is
+found would be incorrect at the time C<run> is called, because it was
+calculated before we moved into the directory "foo".
+
+=end comment
+
+=cut
+
+sub cmd {
+ my $cmd = shift;
+ my %opts = @_;
+ return sub {
+ my $num = shift;
+ # Make a copy to not destroy the caller's array
+ my @cmdargs = ( @$cmd );
+ my @prog = __wrap_cmd(shift @cmdargs, $opts{exe_shell} // ());
+
+ return __decorate_cmd($num, [ @prog, fixup_cmd_elements(@cmdargs) ],
+ %opts);
+ }
+}
+
+sub app {
+ my $cmd = shift;
+ my %opts = @_;
+ return sub {
+ my @cmdargs = ( @{$cmd} );
+ my @prog = __fixup_prg(__apps_file(shift @cmdargs, __exeext()));
+ return cmd([ @prog, @cmdargs ],
+ exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
+ }
+}
+
+sub fuzz {
+ my $cmd = shift;
+ my %opts = @_;
+ return sub {
+ my @cmdargs = ( @{$cmd} );
+ my @prog = __fixup_prg(__fuzz_file(shift @cmdargs, __exeext()));
+ return cmd([ @prog, @cmdargs ],
+ exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
+ }
+}
+
+sub test {
+ my $cmd = shift;
+ my %opts = @_;
+ return sub {
+ my @cmdargs = ( @{$cmd} );
+ my @prog = __fixup_prg(__test_file(shift @cmdargs, __exeext()));
+ return cmd([ @prog, @cmdargs ],
+ exe_shell => $ENV{EXE_SHELL}, %opts) -> (shift);
+ }
+}
+
+sub perlapp {
+ my $cmd = shift;
+ my %opts = @_;
+ return sub {
+ my @interpreter_args = defined $opts{interpreter_args} ?
+ @{$opts{interpreter_args}} : ();
+ my @interpreter = __fixup_prg($^X);
+ my @cmdargs = ( @{$cmd} );
+ my @prog = __apps_file(shift @cmdargs, undef);
+ return cmd([ @interpreter, @interpreter_args,
+ @prog, @cmdargs ], %opts) -> (shift);
+ }
+}
+
+sub perltest {
+ my $cmd = shift;
+ my %opts = @_;
+ return sub {
+ my @interpreter_args = defined $opts{interpreter_args} ?
+ @{$opts{interpreter_args}} : ();
+ my @interpreter = __fixup_prg($^X);
+ my @cmdargs = ( @{$cmd} );
+ my @prog = __test_file(shift @cmdargs, undef);
+ return cmd([ @interpreter, @interpreter_args,
+ @prog, @cmdargs ], %opts) -> (shift);
+ }
+}
+
+=over 4
+
+=item B<run CODEREF, OPTS>
+
+CODEREF is expected to be the value return by C<cmd> or any of its
+derivatives, anything else will most likely cause an error unless you
+know what you're doing.
+
+C<run> executes the command returned by CODEREF and return either the
+resulting standard output (if the option C<capture> is set true) or a boolean
+indicating if the command succeeded or not.
+
+The options that C<run> can take are in the form of hash values:
+
+=over 4
+
+=item B<capture =E<gt> 0|1>
+
+If true, the command will be executed with a perl backtick,
+and C<run> will return the resulting standard output as an array of lines.
+If false or not given, the command will be executed with C<system()>,
+and C<run> will return 1 if the command was successful or 0 if it wasn't.
+
+=item B<prefix =E<gt> EXPR>
+
+If specified, EXPR will be used as a string to prefix the output from the
+command. This is useful if the output contains lines starting with C<ok >
+or C<not ok > that can disturb Test::Harness.
+
+=item B<statusvar =E<gt> VARREF>
+
+If used, B<VARREF> must be a reference to a scalar variable. It will be
+assigned a boolean indicating if the command succeeded or not. This is
+particularly useful together with B<capture>.
+
+=back
+
+Usually 1 indicates that the command was successful and 0 indicates failure.
+For further discussion on what is considered a successful command or not, see
+the function C<with> further down.
+
+=back
+
+=cut
+
+sub run {
+ my ($cmd, $display_cmd) = shift->(0);
+ my %opts = @_;
+
+ return () if !$cmd;
+
+ my $prefix = "";
+ if ( $^O eq "VMS" ) { # VMS
+ $prefix = "pipe ";
+ }
+
+ my @r = ();
+ my $r = 0;
+ my $e = 0;
+
+ die "OpenSSL::Test::run(): statusvar value not a scalar reference"
+ if $opts{statusvar} && ref($opts{statusvar}) ne "SCALAR";
+
+ # For some reason, program output, or even output from this function
+ # somehow isn't caught by TAP::Harness (TAP::Parser?) on VMS, so we're
+ # silencing it specifically there until further notice.
+ my $save_STDOUT;
+ my $save_STDERR;
+ if ($^O eq 'VMS') {
+ # In non-verbose, we want to shut up the command interpreter, in case
+ # it has something to complain about. On VMS, it might complain both
+ # on stdout and stderr
+ if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
+ open $save_STDOUT, '>&', \*STDOUT or die "Can't dup STDOUT: $!";
+ open $save_STDERR, '>&', \*STDERR or die "Can't dup STDERR: $!";
+ open STDOUT, ">", devnull();
+ open STDERR, ">", devnull();
+ }
+ }
+
+ $ENV{HARNESS_OSSL_LEVEL} = $level + 1;
+
+ # The dance we do with $? is the same dance the Unix shells appear to
+ # do. For example, a program that gets aborted (and therefore signals
+ # SIGABRT = 6) will appear to exit with the code 134. We mimic this
+ # to make it easier to compare with a manual run of the command.
+ if ($opts{capture} || defined($opts{prefix})) {
+ my $pipe;
+ local $_;
+
+ open($pipe, '-|', "$prefix$cmd") or die "Can't start command: $!";
+ while(<$pipe>) {
+ my $l = ($opts{prefix} // "") . $_;
+ if ($opts{capture}) {
+ push @r, $l;
+ } else {
+ print STDOUT $l;
+ }
+ }
+ close $pipe;
+ } else {
+ $ENV{HARNESS_OSSL_PREFIX} = "# ";
+ system("$prefix$cmd");
+ delete $ENV{HARNESS_OSSL_PREFIX};
+ }
+ $e = ($? & 0x7f) ? ($? & 0x7f)|0x80 : ($? >> 8);
+ $r = $hooks{exit_checker}->($e);
+ if ($opts{statusvar}) {
+ ${$opts{statusvar}} = $r;
+ }
+
+ # Restore STDOUT / STDERR on VMS
+ if ($^O eq 'VMS') {
+ if ($ENV{HARNESS_ACTIVE} && !$ENV{HARNESS_VERBOSE}) {
+ close STDOUT;
+ close STDERR;
+ open STDOUT, '>&', $save_STDOUT or die "Can't restore STDOUT: $!";
+ open STDERR, '>&', $save_STDERR or die "Can't restore STDERR: $!";
+ }
+
+ print STDERR "$prefix$display_cmd => $e\n"
+ if !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
+ } else {
+ print STDERR "$prefix$display_cmd => $e\n";
+ }
+
+ # At this point, $? stops being interesting, and unfortunately,
+ # there are Test::More versions that get picky if we leave it
+ # non-zero.
+ $? = 0;
+
+ if ($opts{capture}) {
+ return @r;
+ } else {
+ return $r;
+ }
+}
+
+END {
+ my $tb = Test::More->builder;
+ my $failure = scalar(grep { $_ == 0; } $tb->summary);
+ if ($failure && $end_with_bailout) {
+ BAIL_OUT("Stoptest!");
+ }
+}
+
+=head2 Utility functions
+
+The following functions are exported on request when using C<OpenSSL::Test>.
+
+ # To only get the bldtop_file and srctop_file functions.
+ use OpenSSL::Test qw/bldtop_file srctop_file/;
+
+ # To only get the bldtop_file function in addition to the default ones.
+ use OpenSSL::Test qw/:DEFAULT bldtop_file/;
+
+=cut
+
+# Utility functions, exported on request
+
+=over 4
+
+=item B<bldtop_dir LIST>
+
+LIST is a list of directories that make up a path from the top of the OpenSSL
+build directory (as indicated by the environment variable C<$TOP> or
+C<$BLDTOP>).
+C<bldtop_dir> returns the resulting directory as a string, adapted to the local
+operating system.
+
+=back
+
+=cut
+
+sub bldtop_dir {
+ return __bldtop_dir(@_); # This caters for operating systems that have
+ # a very distinct syntax for directories.
+}
+
+=over 4
+
+=item B<bldtop_file LIST, FILENAME>
+
+LIST is a list of directories that make up a path from the top of the OpenSSL
+build directory (as indicated by the environment variable C<$TOP> or
+C<$BLDTOP>) and FILENAME is the name of a file located in that directory path.
+C<bldtop_file> returns the resulting file path as a string, adapted to the local
+operating system.
+
+=back
+
+=cut
+
+sub bldtop_file {
+ return __bldtop_file(@_);
+}
+
+=over 4
+
+=item B<srctop_dir LIST>
+
+LIST is a list of directories that make up a path from the top of the OpenSSL
+source directory (as indicated by the environment variable C<$TOP> or
+C<$SRCTOP>).
+C<srctop_dir> returns the resulting directory as a string, adapted to the local
+operating system.
+
+=back
+
+=cut
+
+sub srctop_dir {
+ return __srctop_dir(@_); # This caters for operating systems that have
+ # a very distinct syntax for directories.
+}
+
+=over 4
+
+=item B<srctop_file LIST, FILENAME>
+
+LIST is a list of directories that make up a path from the top of the OpenSSL
+source directory (as indicated by the environment variable C<$TOP> or
+C<$SRCTOP>) and FILENAME is the name of a file located in that directory path.
+C<srctop_file> returns the resulting file path as a string, adapted to the local
+operating system.
+
+=back
+
+=cut
+
+sub srctop_file {
+ return __srctop_file(@_);
+}
+
+=over 4
+
+=item B<data_dir LIST>
+
+LIST is a list of directories that make up a path from the data directory
+associated with the test (see L</DESCRIPTION> above).
+C<data_dir> returns the resulting directory as a string, adapted to the local
+operating system.
+
+=back
+
+=cut
+
+sub data_dir {
+ return __data_dir(@_);
+}
+
+=over 4
+
+=item B<data_file LIST, FILENAME>
+
+LIST is a list of directories that make up a path from the data directory
+associated with the test (see L</DESCRIPTION> above) and FILENAME is the name
+of a file located in that directory path. C<data_file> returns the resulting
+file path as a string, adapted to the local operating system.
+
+=back
+
+=cut
+
+sub data_file {
+ return __data_file(@_);
+}
+
+=over 4
+
+=item B<result_dir>
+
+C<result_dir> returns the directory where test output files should be placed
+as a string, adapted to the local operating system.
+
+=back
+
+=cut
+
+sub result_dir {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ return catfile($directories{RESULTS});
+}
+
+=over 4
+
+=item B<result_file FILENAME>
+
+FILENAME is the name of a test output file.
+C<result_file> returns the path of the given file as a string,
+prepending to the file name the path to the directory where test output files
+should be placed, adapted to the local operating system.
+
+=back
+
+=cut
+
+sub result_file {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ my $f = pop;
+ return catfile(result_dir(),@_,$f);
+}
+
+=over 4
+
+=item B<pipe LIST>
+
+LIST is a list of CODEREFs returned by C<app> or C<test>, from which C<pipe>
+creates a new command composed of all the given commands put together in a
+pipe. C<pipe> returns a new CODEREF in the same manner as C<app> or C<test>,
+to be passed to C<run> for execution.
+
+=back
+
+=cut
+
+sub pipe {
+ my @cmds = @_;
+ return
+ sub {
+ my @cs = ();
+ my @dcs = ();
+ my @els = ();
+ my $counter = 0;
+ foreach (@cmds) {
+ my ($c, $dc, @el) = $_->(++$counter);
+
+ return () if !$c;
+
+ push @cs, $c;
+ push @dcs, $dc;
+ push @els, @el;
+ }
+ return (
+ join(" | ", @cs),
+ join(" | ", @dcs),
+ @els
+ );
+ };
+}
+
+=over 4
+
+=item B<with HASHREF, CODEREF>
+
+C<with> will temporarily install hooks given by the HASHREF and then execute
+the given CODEREF. Hooks are usually expected to have a coderef as value.
+
+The currently available hoosk are:
+
+=over 4
+
+=item B<exit_checker =E<gt> CODEREF>
+
+This hook is executed after C<run> has performed its given command. The
+CODEREF receives the exit code as only argument and is expected to return
+1 (if the exit code indicated success) or 0 (if the exit code indicated
+failure).
+
+=back
+
+=back
+
+=cut
+
+sub with {
+ my $opts = shift;
+ my %opts = %{$opts};
+ my $codeblock = shift;
+
+ my %saved_hooks = ();
+
+ foreach (keys %opts) {
+ $saved_hooks{$_} = $hooks{$_} if exists($hooks{$_});
+ $hooks{$_} = $opts{$_};
+ }
+
+ $codeblock->();
+
+ foreach (keys %saved_hooks) {
+ $hooks{$_} = $saved_hooks{$_};
+ }
+}
+
+=over 4
+
+=item B<cmdstr CODEREF, OPTS>
+
+C<cmdstr> takes a CODEREF from C<app> or C<test> and simply returns the
+command as a string.
+
+C<cmdstr> takes some additional options OPTS that affect the string returned:
+
+=over 4
+
+=item B<display =E<gt> 0|1>
+
+When set to 0, the returned string will be with all decorations, such as a
+possible redirect of stderr to the null device. This is suitable if the
+string is to be used directly in a recipe.
+
+When set to 1, the returned string will be without extra decorations. This
+is suitable for display if that is desired (doesn't confuse people with all
+internal stuff), or if it's used to pass a command down to a subprocess.
+
+Default: 0
+
+=back
+
+=back
+
+=cut
+
+sub cmdstr {
+ my ($cmd, $display_cmd) = shift->(0);
+ my %opts = @_;
+
+ if ($opts{display}) {
+ return $display_cmd;
+ } else {
+ return $cmd;
+ }
+}
+
+=over 4
+
+=over 4
+
+=item B<openssl_versions>
+
+Returns a list of two version numbers, the first representing the build
+version, the second representing the library version. See opensslv.h for
+more information on those numbers.
+
+=back
+
+=cut
+
+my @versions = ();
+sub openssl_versions {
+ unless (@versions) {
+ my %lines =
+ map { s/\R$//;
+ /^(.*): (.*)$/;
+ $1 => $2 }
+ run(test(['versions']), capture => 1);
+ @versions = ( $lines{'Build version'}, $lines{'Library version'} );
+ }
+ return @versions;
+}
+
+=over 4
+
+=item B<ok_nofips EXPR, TEST_NAME>
+
+C<ok_nofips> is equivalent to using C<ok> when the environment variable
+C<FIPS_MODE> is undefined, otherwise it is equivalent to C<not ok>. This can be
+used for C<ok> tests that must fail when testing a FIPS provider. The parameters
+are the same as used by C<ok> which is an expression EXPR followed by the test
+description TEST_NAME.
+
+An example:
+
+ ok_nofips(run(app(["md5.pl"])), "md5 should fail in fips mode");
+
+=item B<is_nofips EXPR1, EXPR2, TEST_NAME>
+
+C<is_nofips> is equivalent to using C<is> when the environment variable
+C<FIPS_MODE> is undefined, otherwise it is equivalent to C<isnt>. This can be
+used for C<is> tests that must fail when testing a FIPS provider. The parameters
+are the same as used by C<is> which has 2 arguments EXPR1 and EXPR2 that can be
+compared using eq or ne, followed by a test description TEST_NAME.
+
+An example:
+
+ is_nofips(ultimate_answer(), 42, "Meaning of Life");
+
+=item B<isnt_nofips EXPR1, EXPR2, TEST_NAME>
+
+C<isnt_nofips> is equivalent to using C<isnt> when the environment variable
+C<FIPS_MODE> is undefined, otherwise it is equivalent to C<is>. This can be
+used for C<isnt> tests that must fail when testing a FIPS provider. The
+parameters are the same as used by C<isnt> which has 2 arguments EXPR1 and EXPR2
+that can be compared using ne or eq, followed by a test description TEST_NAME.
+
+An example:
+
+ isnt_nofips($foo, '', "Got some foo");
+
+=back
+
+=cut
+
+sub ok_nofips {
+ return ok(!$_[0], @_[1..$#_]) if defined $ENV{FIPS_MODE};
+ return ok($_[0], @_[1..$#_]);
+}
+
+sub is_nofips {
+ return isnt($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE};
+ return is($_[0], $_[1], @_[2..$#_]);
+}
+
+sub isnt_nofips {
+ return is($_[0], $_[1], @_[2..$#_]) if defined $ENV{FIPS_MODE};
+ return isnt($_[0], $_[1], @_[2..$#_]);
+}
+
+######################################################################
+# private functions. These are never exported.
+
+=head1 ENVIRONMENT
+
+OpenSSL::Test depends on some environment variables.
+
+=over 4
+
+=item B<TOP>
+
+This environment variable is mandatory. C<setup> will check that it's
+defined and that it's a directory that contains the file C<Configure>.
+If this isn't so, C<setup> will C<BAIL_OUT>.
+
+=item B<BIN_D>
+
+If defined, its value should be the directory where the openssl application
+is located. Defaults to C<$TOP/apps> (adapted to the operating system).
+
+=item B<TEST_D>
+
+If defined, its value should be the directory where the test applications
+are located. Defaults to C<$TOP/test> (adapted to the operating system).
+
+=item B<STOPTEST>
+
+If defined, it puts testing in a different mode, where a recipe with
+failures will result in a C<BAIL_OUT> at the end of its run.
+
+=item B<FIPS_MODE>
+
+If defined it indicates that the FIPS provider is being tested. Tests may use
+B<ok_nofips>, B<is_nofips> and B<isnt_nofips> to invert test results
+i.e. Some tests may only work in non FIPS mode.
+
+=back
+
+=cut
+
+sub __env {
+ (my $recipe_datadir = basename($0)) =~ s/\.t$/_data/i;
+
+ $directories{SRCTOP} = abs_path($ENV{SRCTOP} || $ENV{TOP});
+ $directories{BLDTOP} = abs_path($ENV{BLDTOP} || $ENV{TOP});
+ $directories{BLDAPPS} = $ENV{BIN_D} || __bldtop_dir("apps");
+ $directories{SRCAPPS} = __srctop_dir("apps");
+ $directories{BLDFUZZ} = __bldtop_dir("fuzz");
+ $directories{SRCFUZZ} = __srctop_dir("fuzz");
+ $directories{BLDTEST} = $ENV{TEST_D} || __bldtop_dir("test");
+ $directories{SRCTEST} = __srctop_dir("test");
+ $directories{SRCDATA} = __srctop_dir("test", "recipes",
+ $recipe_datadir);
+ $directories{RESULTTOP} = $ENV{RESULT_D} || __bldtop_dir("test-runs");
+ $directories{RESULTS} = catdir($directories{RESULTTOP}, $test_name);
+
+ # Create result directory dynamically
+ rmtree($directories{RESULTS}, { safe => 0, keep_root => 1 });
+ mkpath($directories{RESULTS});
+
+ # All directories are assumed to exist, except for SRCDATA. If that one
+ # doesn't exist, just drop it.
+ delete $directories{SRCDATA} unless -d $directories{SRCDATA};
+
+ push @direnv, "TOP" if $ENV{TOP};
+ push @direnv, "SRCTOP" if $ENV{SRCTOP};
+ push @direnv, "BLDTOP" if $ENV{BLDTOP};
+ push @direnv, "BIN_D" if $ENV{BIN_D};
+ push @direnv, "TEST_D" if $ENV{TEST_D};
+ push @direnv, "RESULT_D" if $ENV{RESULT_D};
+
+ $end_with_bailout = $ENV{STOPTEST} ? 1 : 0;
+};
+
+# __srctop_file and __srctop_dir are helpers to build file and directory
+# names on top of the source directory. They depend on $SRCTOP, and
+# therefore on the proper use of setup() and when needed, indir().
+# __bldtop_file and __bldtop_dir do the same thing but relative to $BLDTOP.
+# __srctop_file and __bldtop_file take the same kind of argument as
+# File::Spec::Functions::catfile.
+# Similarly, __srctop_dir and __bldtop_dir take the same kind of argument
+# as File::Spec::Functions::catdir
+sub __srctop_file {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ my $f = pop;
+ return abs2rel(catfile($directories{SRCTOP},@_,$f),getcwd);
+}
+
+sub __srctop_dir {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ return abs2rel(catdir($directories{SRCTOP},@_), getcwd);
+}
+
+sub __bldtop_file {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ my $f = pop;
+ return abs2rel(catfile($directories{BLDTOP},@_,$f), getcwd);
+}
+
+sub __bldtop_dir {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ return abs2rel(catdir($directories{BLDTOP},@_), getcwd);
+}
+
+# __exeext is a function that returns the platform dependent file extension
+# for executable binaries, or the value of the environment variable $EXE_EXT
+# if that one is defined.
+sub __exeext {
+ my $ext = "";
+ if ($^O eq "VMS" ) { # VMS
+ $ext = ".exe";
+ } elsif ($^O eq "MSWin32") { # Windows
+ $ext = ".exe";
+ }
+ return $ENV{"EXE_EXT"} || $ext;
+}
+
+# __test_file, __apps_file and __fuzz_file return the full path to a file
+# relative to the test/, apps/ or fuzz/ directory in the build tree or the
+# source tree, depending on where the file is found. Note that when looking
+# in the build tree, the file name with an added extension is looked for, if
+# an extension is given. The intent is to look for executable binaries (in
+# the build tree) or possibly scripts (in the source tree).
+# These functions all take the same arguments as File::Spec::Functions::catfile,
+# *plus* a mandatory extension argument. This extension argument can be undef,
+# and is ignored in such a case.
+sub __test_file {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ my $e = pop || "";
+ my $f = pop;
+ my $out = catfile($directories{BLDTEST},@_,$f . $e);
+ $out = catfile($directories{SRCTEST},@_,$f) unless -f $out;
+ return $out;
+}
+
+sub __apps_file {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ my $e = pop || "";
+ my $f = pop;
+ my $out = catfile($directories{BLDAPPS},@_,$f . $e);
+ $out = catfile($directories{SRCAPPS},@_,$f) unless -f $out;
+ return $out;
+}
+
+sub __fuzz_file {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ my $e = pop || "";
+ my $f = pop;
+ my $out = catfile($directories{BLDFUZZ},@_,$f . $e);
+ $out = catfile($directories{SRCFUZZ},@_,$f) unless -f $out;
+ return $out;
+}
+
+sub __data_file {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ return undef unless exists $directories{SRCDATA};
+
+ my $f = pop;
+ return catfile($directories{SRCDATA},@_,$f);
+}
+
+sub __data_dir {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ return undef unless exists $directories{SRCDATA};
+
+ return catdir($directories{SRCDATA},@_);
+}
+
+# __cwd DIR
+# __cwd DIR, OPTS
+#
+# __cwd changes directory to DIR (string) and changes all the relative
+# entries in %directories accordingly. OPTS is an optional series of
+# hash style arguments to alter __cwd's behavior:
+#
+# create = 0|1 The directory we move to is created if 1, not if 0.
+
+sub __cwd {
+ my $dir = catdir(shift);
+ my %opts = @_;
+
+ # If the directory is to be created, we must do that before using
+ # abs_path().
+ $dir = canonpath($dir);
+ if ($opts{create}) {
+ mkpath($dir);
+ }
+
+ my $abscurdir = abs_path(curdir());
+ my $absdir = abs_path($dir);
+ my $reverse = abs2rel($abscurdir, $absdir);
+
+ # PARANOIA: if we're not moving anywhere, we do nothing more
+ if ($abscurdir eq $absdir) {
+ return $reverse;
+ }
+
+ # Do not support a move to a different volume for now. Maybe later.
+ BAIL_OUT("FAILURE: \"$dir\" moves to a different volume, not supported")
+ if $reverse eq $abscurdir;
+
+ # If someone happened to give a directory that leads back to the current,
+ # it's extremely silly to do anything more, so just simulate that we did
+ # move.
+ # In this case, we won't even clean it out, for safety's sake.
+ return "." if $reverse eq "";
+
+ # We are recalculating the directories we keep track of, but need to save
+ # away the result for after having moved into the new directory.
+ my %tmp_directories = ();
+ my %tmp_ENV = ();
+
+ # For each of these directory variables, figure out where they are relative
+ # to the directory we want to move to if they aren't absolute (if they are,
+ # they don't change!)
+ my @dirtags = sort keys %directories;
+ foreach (@dirtags) {
+ if (!file_name_is_absolute($directories{$_})) {
+ my $oldpath = abs_path($directories{$_});
+ my $newpath = abs2rel($oldpath, $absdir);
+ if ($debug) {
+ print STDERR "DEBUG: [dir $_] old path: $oldpath\n";
+ print STDERR "DEBUG: [dir $_] new base: $absdir\n";
+ print STDERR "DEBUG: [dir $_] resulting new path: $newpath\n";
+ }
+ $tmp_directories{$_} = $newpath;
+ }
+ }
+
+ # Treat each environment variable that was used to get us the values in
+ # %directories the same was as the paths in %directories, so any sub
+ # process can use their values properly as well
+ foreach (@direnv) {
+ if (!file_name_is_absolute($ENV{$_})) {
+ my $oldpath = abs_path($ENV{$_});
+ my $newpath = abs2rel($oldpath, $absdir);
+ if ($debug) {
+ print STDERR "DEBUG: [env $_] old path: $oldpath\n";
+ print STDERR "DEBUG: [env $_] new base: $absdir\n";
+ print STDERR "DEBUG: [env $_] resulting new path: $newpath\n";
+ }
+ $tmp_ENV{$_} = $newpath;
+ }
+ }
+
+ # Should we just bail out here as well? I'm unsure.
+ return undef unless chdir($dir);
+
+ # We put back new values carefully. Doing the obvious
+ # %directories = ( %tmp_directories )
+ # will clear out any value that happens to be an absolute path
+ foreach (keys %tmp_directories) {
+ $directories{$_} = $tmp_directories{$_};
+ }
+ foreach (keys %tmp_ENV) {
+ $ENV{$_} = $tmp_ENV{$_};
+ }
+
+ if ($debug) {
+ print STDERR "DEBUG: __cwd(), directories and files:\n";
+ print STDERR " Moving from $abscurdir\n";
+ print STDERR " Moving to $absdir\n";
+ print STDERR "\n";
+ print STDERR " \$directories{BLDTEST} = \"$directories{BLDTEST}\"\n";
+ print STDERR " \$directories{SRCTEST} = \"$directories{SRCTEST}\"\n";
+ print STDERR " \$directories{SRCDATA} = \"$directories{SRCDATA}\"\n"
+ if exists $directories{SRCDATA};
+ print STDERR " \$directories{RESULTS} = \"$directories{RESULTS}\"\n";
+ print STDERR " \$directories{BLDAPPS} = \"$directories{BLDAPPS}\"\n";
+ print STDERR " \$directories{SRCAPPS} = \"$directories{SRCAPPS}\"\n";
+ print STDERR " \$directories{SRCTOP} = \"$directories{SRCTOP}\"\n";
+ print STDERR " \$directories{BLDTOP} = \"$directories{BLDTOP}\"\n";
+ print STDERR "\n";
+ print STDERR " the way back is \"$reverse\"\n";
+ }
+
+ return $reverse;
+}
+
+# __wrap_cmd CMD
+# __wrap_cmd CMD, EXE_SHELL
+#
+# __wrap_cmd "wraps" CMD (string) with a beginning command that makes sure
+# the command gets executed with an appropriate environment. If EXE_SHELL
+# is given, it is used as the beginning command.
+#
+# __wrap_cmd returns a list that should be used to build up a larger list
+# of command tokens, or be joined together like this:
+#
+# join(" ", __wrap_cmd($cmd))
+sub __wrap_cmd {
+ my $cmd = shift;
+ my $exe_shell = shift;
+
+ my @prefix = ();
+
+ if (defined($exe_shell)) {
+ # If $exe_shell is defined, trust it
+ @prefix = ( $exe_shell );
+ } else {
+ # Otherwise, use the standard wrapper
+ my $std_wrapper = __bldtop_file("util", "wrap.pl");
+
+ if ($^O eq "VMS" || $^O eq "MSWin32") {
+ # On VMS and Windows, we run the perl executable explicitly,
+ # with necessary fixups. We might not need that for Windows,
+ # but that depends on if the user has associated the '.pl'
+ # extension with a perl interpreter, so better be safe.
+ @prefix = ( __fixup_prg($^X), $std_wrapper );
+ } else {
+ # Otherwise, we assume Unix semantics, and trust that the #!
+ # line activates perl for us.
+ @prefix = ( $std_wrapper );
+ }
+ }
+
+ return (@prefix, $cmd);
+}
+
+# __fixup_prg PROG
+#
+# __fixup_prg does whatever fixup is needed to execute an executable binary
+# given by PROG (string).
+#
+# __fixup_prg returns a string with the possibly prefixed program path spec.
+sub __fixup_prg {
+ my $prog = shift;
+
+ return join(' ', fixup_cmd($prog));
+}
+
+# __decorate_cmd NUM, CMDARRAYREF
+#
+# __decorate_cmd takes a command number NUM and a command token array
+# CMDARRAYREF, builds up a command string from them and decorates it
+# with necessary redirections.
+# __decorate_cmd returns a list of two strings, one with the command
+# string to actually be used, the other to be displayed for the user.
+# The reason these strings might differ is that we redirect stderr to
+# the null device unless we're verbose and unless the user has
+# explicitly specified a stderr redirection.
+sub __decorate_cmd {
+ BAIL_OUT("Must run setup() first") if (! $test_name);
+
+ my $num = shift;
+ my $cmd = shift;
+ my %opts = @_;
+
+ my $cmdstr = join(" ", @$cmd);
+ my $null = devnull();
+ my $fileornull = sub { $_[0] ? $_[0] : $null; };
+ my $stdin = "";
+ my $stdout = "";
+ my $stderr = "";
+ my $saved_stderr = undef;
+ $stdin = " < ".$fileornull->($opts{stdin}) if exists($opts{stdin});
+ $stdout= " > ".$fileornull->($opts{stdout}) if exists($opts{stdout});
+ $stderr=" 2> ".$fileornull->($opts{stderr}) if exists($opts{stderr});
+
+ my $display_cmd = "$cmdstr$stdin$stdout$stderr";
+
+ # VMS program output escapes TAP::Parser
+ if ($^O eq 'VMS') {
+ $stderr=" 2> ".$null
+ unless $stderr || !$ENV{HARNESS_ACTIVE} || $ENV{HARNESS_VERBOSE};
+ }
+
+ $cmdstr .= "$stdin$stdout$stderr";
+
+ if ($debug) {
+ print STDERR "DEBUG[__decorate_cmd]: \$cmdstr = \"$cmdstr\"\n";
+ print STDERR "DEBUG[__decorate_cmd]: \$display_cmd = \"$display_cmd\"\n";
+ }
+
+ return ($cmdstr, $display_cmd);
+}
+
+=head1 SEE ALSO
+
+L<Test::More>, L<Test::Harness>
+
+=head1 AUTHORS
+
+Richard Levitte E<lt>levitte@openssl.orgE<gt> with assistance and
+inspiration from Andy Polyakov E<lt>appro@openssl.org<gt>.
+
+=cut
+
+no warnings 'redefine';
+sub subtest {
+ $level++;
+
+ Test::More::subtest @_;
+
+ $level--;
+};
+
+1;
diff --git a/util/perl/OpenSSL/Test/Simple.pm b/util/perl/OpenSSL/Test/Simple.pm
new file mode 100644
index 000000000000..7875ca579834
--- /dev/null
+++ b/util/perl/OpenSSL/Test/Simple.pm
@@ -0,0 +1,91 @@
+# Copyright 2016 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::Test::Simple;
+
+use strict;
+use warnings;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+$VERSION = "0.2";
+@ISA = qw(Exporter);
+@EXPORT = qw(simple_test);
+
+=head1 NAME
+
+OpenSSL::Test::Simple - a few very simple test functions
+
+=head1 SYNOPSIS
+
+ use OpenSSL::Test::Simple;
+
+ simple_test("my_test_name", "destest", "des");
+
+=head1 DESCRIPTION
+
+Sometimes, the functions in L<OpenSSL::Test> are quite tedious for some
+repetitive tasks. This module provides functions to make life easier.
+You could call them hacks if you wish.
+
+=cut
+
+use OpenSSL::Test;
+use OpenSSL::Test::Utils;
+
+=over 4
+
+=item B<simple_test NAME, PROGRAM, ALGORITHM>
+
+Runs a test named NAME, running the program PROGRAM with no arguments,
+to test the algorithm ALGORITHM.
+
+A complete recipe looks like this:
+
+ use OpenSSL::Test::Simple;
+
+ simple_test("test_bf", "bftest", "bf");
+
+=back
+
+=cut
+
+# args:
+# name (used with setup())
+# algorithm (used to check if it's at all supported)
+# name of binary (the program that does the actual test)
+sub simple_test {
+ my ($name, $prgr, @algos) = @_;
+
+ setup($name);
+
+ if (scalar(disabled(@algos))) {
+ if (scalar(@algos) == 1) {
+ plan skip_all => $algos[0]." is not supported by this OpenSSL build";
+ } else {
+ my $last = pop @algos;
+ plan skip_all => join(", ", @algos)." and $last are not supported by this OpenSSL build";
+ }
+ }
+
+ plan tests => 1;
+
+ ok(run(test([$prgr])), "running $prgr");
+}
+
+=head1 SEE ALSO
+
+L<OpenSSL::Test>
+
+=head1 AUTHORS
+
+Richard Levitte E<lt>levitte@openssl.orgE<gt> with inspiration
+from Rich Salz E<lt>rsalz@openssl.orgE<gt>.
+
+=cut
+
+1;
diff --git a/util/perl/OpenSSL/Test/Utils.pm b/util/perl/OpenSSL/Test/Utils.pm
new file mode 100644
index 000000000000..dcff6a5c9967
--- /dev/null
+++ b/util/perl/OpenSSL/Test/Utils.pm
@@ -0,0 +1,241 @@
+# Copyright 2016-2019 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::Test::Utils;
+
+use strict;
+use warnings;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+$VERSION = "0.1";
+@ISA = qw(Exporter);
+@EXPORT = qw(alldisabled anydisabled disabled config available_protocols
+ have_IPv4 have_IPv6);
+
+=head1 NAME
+
+OpenSSL::Test::Utils - test utility functions
+
+=head1 SYNOPSIS
+
+ use OpenSSL::Test::Utils;
+
+ my @tls = available_protocols("tls");
+ my @dtls = available_protocols("dtls");
+ alldisabled("dh", "dsa");
+ anydisabled("dh", "dsa");
+
+ config("fips");
+
+ have_IPv4();
+ have_IPv6();
+
+=head1 DESCRIPTION
+
+This module provides utility functions for the testing framework.
+
+=cut
+
+use OpenSSL::Test qw/:DEFAULT bldtop_file/;
+
+=over 4
+
+=item B<available_protocols STRING>
+
+Returns a list of strings for all the available SSL/TLS versions if
+STRING is "tls", or for all the available DTLS versions if STRING is
+"dtls". Otherwise, it returns the empty list. The strings in the
+returned list can be used with B<alldisabled> and B<anydisabled>.
+
+=item B<alldisabled ARRAY>
+
+=item B<anydisabled ARRAY>
+
+In an array context returns an array with each element set to 1 if the
+corresponding feature is disabled and 0 otherwise.
+
+In a scalar context, alldisabled returns 1 if all of the features in
+ARRAY are disabled, while anydisabled returns 1 if any of them are
+disabled.
+
+=item B<config STRING>
+
+Returns an item from the %config hash in \$TOP/configdata.pm.
+
+=item B<have_IPv4>
+
+=item B<have_IPv6>
+
+Return true if IPv4 / IPv6 is possible to use on the current system.
+
+=back
+
+=cut
+
+our %available_protocols;
+our %disabled;
+our %config;
+my $configdata_loaded = 0;
+
+sub load_configdata {
+ # We eval it so it doesn't run at compile time of this file.
+ # The latter would have bldtop_file() complain that setup() hasn't
+ # been run yet.
+ my $configdata = bldtop_file("configdata.pm");
+ eval { require $configdata;
+ %available_protocols = %configdata::available_protocols;
+ %disabled = %configdata::disabled;
+ %config = %configdata::config;
+ };
+ $configdata_loaded = 1;
+}
+
+# args
+# list of 1s and 0s, coming from check_disabled()
+sub anyof {
+ my $x = 0;
+ foreach (@_) { $x += $_ }
+ return $x > 0;
+}
+
+# args
+# list of 1s and 0s, coming from check_disabled()
+sub allof {
+ my $x = 1;
+ foreach (@_) { $x *= $_ }
+ return $x > 0;
+}
+
+# args
+# list of strings, all of them should be names of features
+# that can be disabled.
+# returns a list of 1s (if the corresponding feature is disabled)
+# and 0s (if it isn't)
+sub check_disabled {
+ return map { exists $disabled{lc $_} ? 1 : 0 } @_;
+}
+
+# Exported functions #################################################
+
+# args:
+# list of features to check
+sub anydisabled {
+ load_configdata() unless $configdata_loaded;
+ my @ret = check_disabled(@_);
+ return @ret if wantarray;
+ return anyof(@ret);
+}
+
+# args:
+# list of features to check
+sub alldisabled {
+ load_configdata() unless $configdata_loaded;
+ my @ret = check_disabled(@_);
+ return @ret if wantarray;
+ return allof(@ret);
+}
+
+# !!! Kept for backward compatibility
+# args:
+# single string
+sub disabled {
+ anydisabled(@_);
+}
+
+sub available_protocols {
+ load_configdata() unless $configdata_loaded;
+ my $protocol_class = shift;
+ if (exists $available_protocols{lc $protocol_class}) {
+ return @{$available_protocols{lc $protocol_class}}
+ }
+ return ();
+}
+
+sub config {
+ load_configdata() unless $configdata_loaded;
+ return $config{$_[0]};
+}
+
+# IPv4 / IPv6 checker
+my $have_IPv4 = -1;
+my $have_IPv6 = -1;
+my $IP_factory;
+sub check_IP {
+ my $listenaddress = shift;
+
+ eval {
+ require IO::Socket::IP;
+ my $s = IO::Socket::IP->new(
+ LocalAddr => $listenaddress,
+ LocalPort => 0,
+ Listen=>1,
+ );
+ $s or die "\n";
+ $s->close();
+ };
+ if ($@ eq "") {
+ return 1;
+ }
+
+ eval {
+ require IO::Socket::INET6;
+ my $s = IO::Socket::INET6->new(
+ LocalAddr => $listenaddress,
+ LocalPort => 0,
+ Listen=>1,
+ );
+ $s or die "\n";
+ $s->close();
+ };
+ if ($@ eq "") {
+ return 1;
+ }
+
+ eval {
+ require IO::Socket::INET;
+ my $s = IO::Socket::INET->new(
+ LocalAddr => $listenaddress,
+ LocalPort => 0,
+ Listen=>1,
+ );
+ $s or die "\n";
+ $s->close();
+ };
+ if ($@ eq "") {
+ return 1;
+ }
+
+ return 0;
+}
+
+sub have_IPv4 {
+ if ($have_IPv4 < 0) {
+ $have_IPv4 = check_IP("127.0.0.1");
+ }
+ return $have_IPv4;
+}
+
+sub have_IPv6 {
+ if ($have_IPv6 < 0) {
+ $have_IPv6 = check_IP("::1");
+ }
+ return $have_IPv6;
+}
+
+=head1 SEE ALSO
+
+L<OpenSSL::Test>
+
+=head1 AUTHORS
+
+Stephen Henson E<lt>steve@openssl.orgE<gt> and
+Richard Levitte E<lt>levitte@openssl.orgE<gt>
+
+=cut
+
+1;
diff --git a/util/perl/OpenSSL/Util.pm b/util/perl/OpenSSL/Util.pm
new file mode 100644
index 000000000000..44e87afee2e3
--- /dev/null
+++ b/util/perl/OpenSSL/Util.pm
@@ -0,0 +1,310 @@
+#! /usr/bin/env perl
+# Copyright 2018-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::Util;
+
+use strict;
+use warnings;
+use Carp;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+$VERSION = "0.1";
+@ISA = qw(Exporter);
+@EXPORT = qw(cmp_versions quotify1 quotify_l fixup_cmd_elements fixup_cmd
+ dump_data);
+@EXPORT_OK = qw();
+
+=head1 NAME
+
+OpenSSL::Util - small OpenSSL utilities
+
+=head1 SYNOPSIS
+
+ use OpenSSL::Util;
+
+ $versiondiff = cmp_versions('1.0.2k', '3.0.1');
+ # $versiondiff should be -1
+
+ $versiondiff = cmp_versions('1.1.0', '1.0.2a');
+ # $versiondiff should be 1
+
+ $versiondiff = cmp_versions('1.1.1', '1.1.1');
+ # $versiondiff should be 0
+
+=head1 DESCRIPTION
+
+=over
+
+=item B<cmp_versions "VERSION1", "VERSION2">
+
+Compares VERSION1 with VERSION2, paying attention to OpenSSL versioning.
+
+Returns 1 if VERSION1 is greater than VERSION2, 0 if they are equal, and
+-1 if VERSION1 is less than VERSION2.
+
+=back
+
+=cut
+
+# Until we're rid of everything with the old version scheme,
+# we need to be able to handle older style x.y.zl versions.
+# In terms of comparison, the x.y.zl and the x.y.z schemes
+# are compatible... mostly because the latter starts at a
+# new major release with a new major number.
+sub _ossl_versionsplit {
+ my $textversion = shift;
+ return $textversion if $textversion eq '*';
+ my ($major,$minor,$edit,$letter) =
+ $textversion =~ /^(\d+)\.(\d+)\.(\d+)([a-z]{0,2})$/;
+
+ return ($major,$minor,$edit,$letter);
+}
+
+sub cmp_versions {
+ my @a_split = _ossl_versionsplit(shift);
+ my @b_split = _ossl_versionsplit(shift);
+ 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 {
+ $verdict = $a_split[0] <=> $b_split[0];
+ }
+ shift @a_split;
+ shift @b_split;
+ last unless $verdict == 0;
+ }
+
+ return $verdict;
+}
+
+# It might be practical to quotify some strings and have them protected
+# from possible harm. These functions primarily quote things that might
+# be interpreted wrongly by a perl eval.
+
+=over 4
+
+=item quotify1 STRING
+
+This adds quotes (") around the given string, and escapes any $, @, \,
+" and ' by prepending a \ to them.
+
+=back
+
+=cut
+
+sub quotify1 {
+ my $s = shift @_;
+ $s =~ s/([\$\@\\"'])/\\$1/g;
+ '"'.$s.'"';
+}
+
+=over 4
+
+=item quotify_l LIST
+
+For each defined element in LIST (i.e. elements that aren't undef), have
+it quotified with 'quotify1'.
+Undefined elements are ignored.
+
+=cut
+
+sub quotify_l {
+ map {
+ if (!defined($_)) {
+ ();
+ } else {
+ quotify1($_);
+ }
+ } @_;
+}
+
+=over 4
+
+=item fixup_cmd_elements LIST
+
+Fixes up the command line elements given by LIST in a platform specific
+manner.
+
+The result of this function is a copy of LIST with strings where quotes and
+escapes have been injected as necessary depending on the content of each
+LIST string.
+
+This can also be used to put quotes around the executable of a command.
+I<This must never ever be done on VMS.>
+
+=back
+
+=cut
+
+sub fixup_cmd_elements {
+ # A formatter for the command arguments, defaulting to the Unix setup
+ my $arg_formatter =
+ sub { $_ = shift;
+ ($_ eq '' || /\s|[\{\}\\\$\[\]\*\?\|\&:;<>]/) ? "'$_'" : $_ };
+
+ if ( $^O eq "VMS") { # VMS setup
+ $arg_formatter = sub {
+ $_ = shift;
+ if ($_ eq '' || /\s|[!"[:upper:]]/) {
+ s/"/""/g;
+ '"'.$_.'"';
+ } else {
+ $_;
+ }
+ };
+ } elsif ( $^O eq "MSWin32") { # MSWin setup
+ $arg_formatter = sub {
+ $_ = shift;
+ if ($_ eq '' || /\s|["\|\&\*\;<>]/) {
+ s/(["\\])/\\$1/g;
+ '"'.$_.'"';
+ } else {
+ $_;
+ }
+ };
+ }
+
+ return ( map { $arg_formatter->($_) } @_ );
+}
+
+=over 4
+
+=item fixup_cmd LIST
+
+This is a sibling of fixup_cmd_elements() that expects the LIST to be a
+complete command line. It does the same thing as fixup_cmd_elements(),
+expect that it treats the first LIST element specially on VMS.
+
+=back
+
+=cut
+
+sub fixup_cmd {
+ return fixup_cmd_elements(@_) unless $^O eq 'VMS';
+
+ # The rest is VMS specific
+ my $prog = shift;
+
+ # On VMS, running random executables without having a command symbol
+ # means running them with the MCR command. This is an old PDP-11
+ # command that stuck around.
+ # This assumes that we're passed the name of an executable. This is a
+ # safe assumption for OpenSSL command lines
+ my $prefix = 'MCR';
+
+ if ($prog =~ /^MCR$/i) {
+ # If the first element is "MCR" (independent of case) already, then
+ # we assume that the program it runs is already written the way it
+ # should, and just grab it.
+ $prog = shift;
+ } else {
+ # If the command itself doesn't have a directory spec, make sure
+ # that there is one. Otherwise, MCR assumes that the program
+ # resides in SYS$SYSTEM:
+ $prog = '[]' . $prog unless $prog =~ /^(?:[\$a-z0-9_]+:)?[<\[]/i;
+ }
+
+ return ( $prefix, $prog, fixup_cmd_elements(@_) );
+}
+
+=item dump_data REF, OPTS
+
+Dump the data from REF into a string that can be evaluated into the same
+data by Perl.
+
+OPTS is the rest of the arguments, expected to be pairs formed with C<< => >>.
+The following OPTS keywords are understood:
+
+=over 4
+
+=item B<delimiters =E<gt> 0 | 1>
+
+Include the outer delimiter of the REF type in the resulting string if C<1>,
+otherwise not.
+
+=item B<indent =E<gt> num>
+
+The indentation of the caller, i.e. an initial value. If not given, there
+will be no indentation at all, and the string will only be one line.
+
+=back
+
+=cut
+
+sub dump_data {
+ my $ref = shift;
+ # Available options:
+ # indent => callers indentation ( undef for no indentation,
+ # an integer otherwise )
+ # delimiters => 1 if outer delimiters should be added
+ my %opts = @_;
+
+ my $indent = $opts{indent} // 1;
+ # Indentation of the whole structure, where applicable
+ my $nlindent1 = defined $opts{indent} ? "\n" . ' ' x $indent : ' ';
+ # Indentation of individual items, where applicable
+ my $nlindent2 = defined $opts{indent} ? "\n" . ' ' x ($indent + 4) : ' ';
+ my %subopts = ();
+
+ $subopts{delimiters} = 1;
+ $subopts{indent} = $opts{indent} + 4 if defined $opts{indent};
+
+ my $product; # Finished product, or reference to a function that
+ # produces a string, given $_
+ # The following are only used when $product is a function reference
+ my $delim_l; # Left delimiter of structure
+ my $delim_r; # Right delimiter of structure
+ my $separator; # Item separator
+ my @items; # Items to iterate over
+
+ if (ref($ref) eq "ARRAY") {
+ if (scalar @$ref == 0) {
+ $product = $opts{delimiters} ? '[]' : '';
+ } else {
+ $product = sub {
+ dump_data(\$_, %subopts)
+ };
+ $delim_l = ($opts{delimiters} ? '[' : '').$nlindent2;
+ $delim_r = $nlindent1.($opts{delimiters} ? ']' : '');
+ $separator = ",$nlindent2";
+ @items = @$ref;
+ }
+ } elsif (ref($ref) eq "HASH") {
+ if (scalar keys %$ref == 0) {
+ $product = $opts{delimiters} ? '{}' : '';
+ } else {
+ $product = sub {
+ quotify1($_) . " => " . dump_data($ref->{$_}, %subopts);
+ };
+ $delim_l = ($opts{delimiters} ? '{' : '').$nlindent2;
+ $delim_r = $nlindent1.($opts{delimiters} ? '}' : '');
+ $separator = ",$nlindent2";
+ @items = sort keys %$ref;
+ }
+ } elsif (ref($ref) eq "SCALAR") {
+ $product = defined $$ref ? quotify1 $$ref : "undef";
+ } else {
+ $product = defined $ref ? quotify1 $ref : "undef";
+ }
+
+ if (ref($product) eq "CODE") {
+ $delim_l . join($separator, map { &$product } @items) . $delim_r;
+ } else {
+ $product;
+ }
+}
+
+=back
+
+=cut
+
+1;
diff --git a/util/perl/OpenSSL/Util/Pod.pm b/util/perl/OpenSSL/Util/Pod.pm
new file mode 100644
index 000000000000..8164e8d75970
--- /dev/null
+++ b/util/perl/OpenSSL/Util/Pod.pm
@@ -0,0 +1,193 @@
+# Copyright 2016-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::Util::Pod;
+
+use strict;
+use warnings;
+
+use Exporter;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+$VERSION = "0.1";
+@ISA = qw(Exporter);
+@EXPORT = qw(extract_pod_info);
+@EXPORT_OK = qw();
+
+=head1 NAME
+
+OpenSSL::Util::Pod - utilities to manipulate .pod files
+
+=head1 SYNOPSIS
+
+ use OpenSSL::Util::Pod;
+
+ my %podinfo = extract_pod_info("foo.pod");
+
+ # or if the file is already opened... Note that this consumes the
+ # remainder of the file.
+
+ my %podinfo = extract_pod_info(\*STDIN);
+
+=head1 DESCRIPTION
+
+=over
+
+=item B<extract_pod_info "FILENAME", HASHREF>
+
+=item B<extract_pod_info "FILENAME">
+
+=item B<extract_pod_info GLOB, HASHREF>
+
+=item B<extract_pod_info GLOB>
+
+Extracts information from a .pod file, given a STRING (file name) or a
+GLOB (a file handle). The result is given back as a hash table.
+
+The additional hash is for extra parameters:
+
+=over
+
+=item B<section =E<gt> N>
+
+The value MUST be a number, and will be the man section number
+to be used with the given .pod file.
+
+=item B<debug =E<gt> 0|1>
+
+If set to 1, extra debug text will be printed on STDERR
+
+=back
+
+=back
+
+=head1 RETURN VALUES
+
+=over
+
+=item B<extract_pod_info> returns a hash table with the following
+items:
+
+=over
+
+=item B<section =E<gt> N>
+
+The man section number this .pod file belongs to. Often the same as
+was given as input.
+
+=item B<names =E<gt> [ "name", ... ]>
+
+All the names extracted from the NAME section.
+
+=item B<contents =E<gt> "...">
+
+The whole contents of the .pod file.
+
+=back
+
+=back
+
+=cut
+
+sub extract_pod_info {
+ my $input = shift;
+ my $defaults_ref = shift || {};
+ my %defaults = ( debug => 0, section => 0, %$defaults_ref );
+ my $fh = undef;
+ my $filename = undef;
+ my $contents;
+
+ # If not a file handle, then it's assume to be a file path (a string)
+ if (ref $input eq "") {
+ $filename = $input;
+ open $fh, $input or die "Trying to read $filename: $!\n";
+ print STDERR "DEBUG: Reading $input\n" if $defaults{debug};
+ $input = $fh;
+ }
+ if (ref $input eq "GLOB") {
+ local $/ = undef;
+ $contents = <$input>;
+ } else {
+ die "Unknown input type";
+ }
+
+ my @invisible_names = ();
+ my %podinfo = ( section => $defaults{section});
+ $podinfo{lastsecttext} = ""; # init needed in case input file is empty
+
+ # Regexp to split a text into paragraphs found at
+ # https://www.perlmonks.org/?node_id=584367
+ # Most of all, \G (continue at last match end) and /g (anchor
+ # this match for \G) are significant
+ foreach (map { /\G((?:(?!\n\n).)*\n+|.+\z)/sg } $contents) {
+ # Remove as many line endings as possible from the end of the paragraph
+ while (s|\R$||) {}
+
+ print STDERR "DEBUG: Paragraph:\n$_\n"
+ if $defaults{debug};
+
+ # Stop reading when we have reached past the NAME section.
+ last if (m|^=head1|
+ && defined $podinfo{lastsect}
+ && $podinfo{lastsect} eq "NAME");
+
+ # Collect the section name
+ if (m|^=head1\s*(.*)|) {
+ $podinfo{lastsect} = $1;
+ $podinfo{lastsect} =~ s/\s+$//;
+ print STDERR "DEBUG: Found new pod section $1\n"
+ if $defaults{debug};
+ print STDERR "DEBUG: Clearing pod section text\n"
+ if $defaults{debug};
+ $podinfo{lastsecttext} = "";
+ }
+
+ # Add invisible names
+ if (m|^=for\s+openssl\s+names:\s*(.*)|s) {
+ my $x = $1;
+ my @tmp = map { map { s/\s+//g; $_ } split(/,/, $_) } $x;
+ print STDERR
+ "DEBUG: Found invisible names: ", join(', ', @tmp), "\n"
+ if $defaults{debug};
+ push @invisible_names, @tmp;
+ }
+
+ next if (m|^=| || m|^\s*$|);
+
+ # Collect the section text
+ print STDERR "DEBUG: accumulating pod section text \"$_\"\n"
+ if $defaults{debug};
+ $podinfo{lastsecttext} .= " " if $podinfo{lastsecttext};
+ $podinfo{lastsecttext} .= $_;
+ }
+
+
+ if (defined $fh) {
+ close $fh;
+ print STDERR "DEBUG: Done reading $filename\n" if $defaults{debug};
+ }
+
+ $podinfo{lastsecttext} =~ s|\s+-\s+.*$||s;
+
+ my @names =
+ map { s/^\s+//g; # Trim prefix blanks
+ s/\s+$//g; # Trim suffix blanks
+ s|/|-|g; # Treat slash as dash
+ $_ }
+ split(m|,|, $podinfo{lastsecttext});
+
+ print STDERR
+ "DEBUG: Collected names are: ",
+ join(', ', @names, @invisible_names), "\n"
+ if $defaults{debug};
+
+ return ( section => $podinfo{section},
+ names => [ @names, @invisible_names ],
+ contents => $contents,
+ filename => $filename );
+}
+
+1;
diff --git a/util/perl/OpenSSL/config.pm b/util/perl/OpenSSL/config.pm
new file mode 100755
index 000000000000..695d6bab0b9f
--- /dev/null
+++ b/util/perl/OpenSSL/config.pm
@@ -0,0 +1,1038 @@
+#! /usr/bin/env perl
+# Copyright 1998-2023 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
+
+# Determine the operating system and run ./Configure. Far descendant from
+# Apache's minarch and GuessOS.
+
+package OpenSSL::config;
+
+use strict;
+use warnings;
+use Getopt::Std;
+use File::Basename;
+use File::Spec;
+use IPC::Cmd;
+use POSIX;
+use Config;
+use Carp;
+
+# These control our behavior.
+my $DRYRUN;
+my $VERBOSE;
+my $WHERE = dirname($0);
+my $WAIT = 1;
+
+# Machine type, etc., used to determine the platform
+my $MACHINE;
+my $RELEASE;
+my $SYSTEM;
+my $VERSION;
+my $CCVENDOR;
+my $CCVER;
+my $CL_ARCH;
+my $GCC_BITS;
+my $GCC_ARCH;
+
+# Some environment variables; they will affect Configure
+my $CONFIG_OPTIONS = $ENV{CONFIG_OPTIONS} // '';
+my $CC;
+my $CROSS_COMPILE;
+
+# For determine_compiler_settings, the list of known compilers
+my @c_compilers = qw(clang gcc cc);
+# Methods to determine compiler version. The expected output is one of
+# MAJOR or MAJOR.MINOR or MAJOR.MINOR.PATCH... or false if the compiler
+# isn't of the given brand.
+# This is a list to ensure that gnu comes last, as we've made it a fallback
+my @cc_version =
+ (
+ clang => sub {
+ return undef unless IPC::Cmd::can_run("$CROSS_COMPILE$CC");
+ my $v = `$CROSS_COMPILE$CC -v 2>&1`;
+ $v =~ m/(?:(?:clang|LLVM) version|.*based on LLVM)\s+([0-9]+\.[0-9]+)/;
+ return $1;
+ },
+ gnu => sub {
+ return undef unless IPC::Cmd::can_run("$CROSS_COMPILE$CC");
+ my $nul = File::Spec->devnull();
+ my $v = `$CROSS_COMPILE$CC -dumpversion 2> $nul`;
+ # Strip off whatever prefix egcs prepends the number with.
+ # Hopefully, this will work for any future prefixes as well.
+ $v =~ s/^[a-zA-Z]*\-//;
+ return $v;
+ },
+ );
+
+# This is what we will set as the target for calling Configure.
+my $options = '';
+
+# Pattern matches against "${SYSTEM}:${RELEASE}:${VERSION}:${MACHINE}"
+# The patterns are assumed to be wrapped like this: /^(${pattern})$/
+my $guess_patterns = [
+ [ 'A\/UX:.*', 'm68k-apple-aux3' ],
+ [ 'AIX:[3-9]:4:.*', '${MACHINE}-ibm-aix' ],
+ [ 'AIX:.*?:[5-9]:.*', '${MACHINE}-ibm-aix' ],
+ [ 'AIX:.*', '${MACHINE}-ibm-aix3' ],
+ [ 'HI-UX:.*', '${MACHINE}-hi-hiux' ],
+ [ 'HP-UX:.*',
+ sub {
+ my $HPUXVER = $RELEASE;
+ $HPUXVER =~ s/[^.]*.[0B]*//;
+ # HPUX 10 and 11 targets are unified
+ return "${MACHINE}-hp-hpux1x" if $HPUXVER =~ m@1[0-9]@;
+ return "${MACHINE}-hp-hpux";
+ }
+ ],
+ [ 'IRIX:6\..*', 'mips3-sgi-irix' ],
+ [ 'IRIX64:.*', 'mips4-sgi-irix64' ],
+ [ 'Linux:[2-9]\..*', '${MACHINE}-whatever-linux2' ],
+ [ 'Linux:1\..*', '${MACHINE}-whatever-linux1' ],
+ [ 'GNU.*', 'hurd-x86' ],
+ [ 'LynxOS:.*', '${MACHINE}-lynx-lynxos' ],
+ # BSD/OS always says 386
+ [ 'BSD\/OS:4\..*', 'i486-whatever-bsdi4' ],
+ # Order is important, this has to appear before 'BSD\/386:'
+ [ 'BSD/386:.*?:.*?:.*486.*|BSD/OS:.*?:.*?:.*?:.*486.*',
+ sub {
+ my $BSDVAR = `/sbin/sysctl -n hw.model`;
+ return "i586-whatever-bsdi" if $BSDVAR =~ m@Pentium@;
+ return "i386-whatever-bsdi";
+ }
+ ],
+ [ 'BSD\/386:.*|BSD\/OS:.*', '${MACHINE}-whatever-bsdi' ],
+ # Order is important, this has to appear before 'FreeBSD:'
+ [ 'FreeBSD:.*?:.*?:.*386.*',
+ sub {
+ my $VERS = $RELEASE;
+ $VERS =~ s/[-(].*//;
+ my $MACH = `sysctl -n hw.model`;
+ $MACH = "i386" if $MACH =~ m@386@;
+ $MACH = "i486" if $MACH =~ m@486@;
+ $MACH = "i686" if $MACH =~ m@Pentium II@;
+ $MACH = "i586" if $MACH =~ m@Pentium@;
+ $MACH = "$MACHINE" if $MACH !~ /i.86/;
+ my $ARCH = 'whatever';
+ $ARCH = "pc" if $MACH =~ m@i[0-9]86@;
+ return "${MACH}-${ARCH}-freebsd${VERS}";
+ }
+ ],
+ [ 'DragonFly:.*', '${MACHINE}-whatever-dragonfly' ],
+ [ 'FreeBSD:.*', '${MACHINE}-whatever-freebsd' ],
+ [ 'Haiku:.*', '${MACHINE}-whatever-haiku' ],
+ # Order is important, this has to appear before 'NetBSD:.*'
+ [ 'NetBSD:.*?:.*?:.*386.*',
+ sub {
+ my $hw = `/usr/sbin/sysctl -n hw.model || /sbin/sysctl -n hw.model`;
+ $hw =~ s@.*(.)86-class.*@i${1}86@;
+ return "${hw}-whatever-netbsd";
+ }
+ ],
+ [ 'NetBSD:.*', '${MACHINE}-whatever-netbsd' ],
+ [ 'OpenBSD:.*', '${MACHINE}-whatever-openbsd' ],
+ [ 'OpenUNIX:.*', '${MACHINE}-unknown-OpenUNIX${VERSION}' ],
+ [ 'OSF1:.*?:.*?:.*alpha.*',
+ sub {
+ my $OSFMAJOR = $RELEASE;
+ $OSFMAJOR =~ 's/^V([0-9]*)\..*$/\1/';
+ return "${MACHINE}-dec-tru64" if $OSFMAJOR =~ m@[45]@;
+ return "${MACHINE}-dec-osf";
+ }
+ ],
+ [ 'Paragon.*?:.*', 'i860-intel-osf1' ],
+ [ 'Rhapsody:.*', 'ppc-apple-rhapsody' ],
+ [ 'Darwin:.*?:.*?:Power.*', 'ppc-apple-darwin' ],
+ [ 'Darwin:.*', '${MACHINE}-apple-darwin' ],
+ [ 'SunOS:5\..*', '${MACHINE}-whatever-solaris2' ],
+ [ 'SunOS:.*', '${MACHINE}-sun-sunos4' ],
+ [ 'UNIX_System_V:4\..*?:.*', '${MACHINE}-whatever-sysv4' ],
+ [ 'VOS:.*?:.*?:i786', 'i386-stratus-vos' ],
+ [ 'VOS:.*?:.*?:.*', 'hppa1.1-stratus-vos' ],
+ [ '.*?:4.*?:R4.*?:m88k', '${MACHINE}-whatever-sysv4' ],
+ [ 'DYNIX\/ptx:4.*?:.*', '${MACHINE}-whatever-sysv4' ],
+ [ '.*?:4\.0:3\.0:3[34]..(,.*)?', 'i486-ncr-sysv4' ],
+ [ 'ULTRIX:.*', '${MACHINE}-unknown-ultrix' ],
+ [ 'POSIX-BC.*', 'BS2000-siemens-sysv4' ],
+ [ 'machten:.*', '${MACHINE}-tenon-${SYSTEM}' ],
+ [ 'library:.*', '${MACHINE}-ncr-sysv4' ],
+ [ 'ConvexOS:.*?:11\.0:.*', '${MACHINE}-v11-${SYSTEM}' ],
+ [ 'MINGW64.*?:.*?:.*?:x86_64', '${MACHINE}-whatever-mingw64' ],
+ [ 'MINGW.*', '${MACHINE}-whatever-mingw' ],
+ [ 'CYGWIN.*', '${MACHINE}-pc-cygwin' ],
+ [ 'vxworks.*', '${MACHINE}-whatever-vxworks' ],
+
+ # The MACHINE part of the array POSIX::uname() returns on VMS isn't
+ # worth the bits wasted on it. It's better, then, to rely on perl's
+ # %Config, which has a trustworthy item 'archname', especially since
+ # VMS installation aren't multiarch (yet)
+ [ 'OpenVMS:.*', "$Config{archname}-whatever-OpenVMS" ],
+
+ # Note: there's also NEO and NSR, but they are old and unsupported
+ [ 'NONSTOP_KERNEL:.*:NSE-.*?', 'nse-tandem-nsk${RELEASE}' ],
+ [ 'NONSTOP_KERNEL:.*:NSV-.*?', 'nsv-tandem-nsk${RELEASE}' ],
+ [ 'NONSTOP_KERNEL:.*:NSX-.*?', 'nsx-tandem-nsk${RELEASE}' ],
+
+ [ sub { -d '/usr/apollo' }, 'whatever-apollo-whatever' ],
+];
+
+# Run a command, return true if exit zero else false.
+# Multiple args are glued together into a pipeline.
+# Name comes from OpenSSL tests, often written as "ok(run(...."
+sub okrun {
+ my $command = join(' | ', @_);
+ my $status = system($command) >> 8;
+ return $status == 0;
+}
+
+# Give user a chance to abort/interrupt if interactive if interactive.
+sub maybe_abort {
+ if ( $WAIT && -t 1 ) {
+ eval {
+ local $SIG{ALRM} = sub { die "Timeout"; };
+ local $| = 1;
+ alarm(5);
+ print "You have about five seconds to abort: ";
+ my $ignored = <STDIN>;
+ alarm(0);
+ };
+ print "\n" if $@ =~ /Timeout/;
+ }
+}
+
+# Look for ISC/SCO with its unique uname program
+sub is_sco_uname {
+ return undef unless IPC::Cmd::can_run('uname');
+
+ open UNAME, "uname -X 2>/dev/null|" or return '';
+ my $line = "";
+ my $os = "";
+ while ( <UNAME> ) {
+ chop;
+ $line = $_ if m@^Release@;
+ $os = $_ if m@^System@;
+ }
+ close UNAME;
+
+ return undef if $line eq '' or $os eq 'System = SunOS';
+
+ my @fields = split(/\s+/, $line);
+ return $fields[2];
+}
+
+sub get_sco_type {
+ my $REL = shift;
+
+ if ( -f "/etc/kconfig" ) {
+ return "${MACHINE}-whatever-isc4" if $REL eq '4.0' || $REL eq '4.1';
+ } else {
+ return "whatever-whatever-sco3" if $REL eq '3.2v4.2';
+ return "whatever-whatever-sco5" if $REL =~ m@3\.2v5\.0.*@;
+ if ( $REL eq "4.2MP" ) {
+ return "whatever-whatever-unixware20" if $VERSION =~ m@2\.0.*@;
+ return "whatever-whatever-unixware21" if $VERSION =~ m@2\.1.*@;
+ return "whatever-whatever-unixware2" if $VERSION =~ m@2.*@;
+ }
+ return "whatever-whatever-unixware1" if $REL eq "4.2";
+ if ( $REL =~ m@5.*@ ) {
+ # We hardcode i586 in place of ${MACHINE} for the following
+ # reason: even though Pentium is minimum requirement for
+ # platforms in question, ${MACHINE} gets always assigned to
+ # i386. This means i386 gets passed to Configure, which will
+ # cause bad assembler code to be generated.
+ return "i586-sco-unixware7" if $VERSION =~ m@[678].*@;
+ }
+ }
+}
+
+# Return the cputype-vendor-osversion
+sub guess_system {
+ ($SYSTEM, undef, $RELEASE, $VERSION, $MACHINE) = POSIX::uname();
+ my $sys = "${SYSTEM}:${RELEASE}:${VERSION}:${MACHINE}";
+
+ # Special-cases for ISC, SCO, Unixware
+ my $REL = is_sco_uname();
+ if ( defined $REL ) {
+ my $result = get_sco_type($REL);
+ return eval "\"$result\"" if $result ne '';
+ }
+
+ # Now pattern-match
+
+ # Simple cases
+ foreach my $tuple ( @$guess_patterns ) {
+ my $pat = @$tuple[0];
+ my $check = ref $pat eq 'CODE' ? $pat->($sys) : $sys =~ /^(${pat})$/;
+ next unless $check;
+
+ my $result = @$tuple[1];
+ $result = $result->() if ref $result eq 'CODE';
+ return eval "\"$result\"";
+ }
+
+ # Oh well.
+ return "${MACHINE}-whatever-${SYSTEM}";
+}
+
+# We would use List::Util::pair() for this... unfortunately, that function
+# only appeared in perl v5.19.3, and we claim to support perl v5.10 and on.
+# Therefore, we implement a quick cheap variant of our own.
+sub _pairs (@) {
+ croak "Odd number of arguments" if @_ & 1;
+
+ my @pairlist = ();
+
+ while (@_) {
+ my $x = [ shift, shift ];
+ push @pairlist, $x;
+ }
+ return @pairlist;
+}
+
+# Figure out CC, GCCVAR, etc.
+sub determine_compiler_settings {
+ # Make a copy and don't touch it. That helps determine if we're finding
+ # the compiler here (false), or if it was set by the user (true.
+ my $cc = $CC;
+
+ # Set certain default
+ $CCVER = 0; # Unknown
+ $CCVENDOR = ''; # Dunno, don't care (unless found later)
+
+ # Find a compiler if we don't already have one
+ if ( ! $cc ) {
+ foreach (@c_compilers) {
+ next unless IPC::Cmd::can_run("$CROSS_COMPILE$_");
+ $CC = $_;
+ last;
+ }
+ }
+
+ if ( $CC ) {
+ # Find the compiler vendor and version number for certain compilers
+ foreach my $pair (_pairs @cc_version) {
+ # Try to get the version number.
+ # Failure gets us undef or an empty string
+ my ( $k, $v ) = @$pair;
+ $v = $v->();
+
+ # If we got a version number, process it
+ if ($v) {
+ $v =~ s/[^.]*.0*// if $SYSTEM eq 'HP-UX';
+ $CCVENDOR = $k;
+
+ # The returned version is expected to be one of
+ #
+ # MAJOR
+ # MAJOR.MINOR
+ # MAJOR.MINOR.{whatever}
+ #
+ # We don't care what comes after MAJOR.MINOR. All we need is
+ # to have them calculated into a single number, using this
+ # formula:
+ #
+ # MAJOR * 100 + MINOR
+ # Here are a few examples of what we should get:
+ #
+ # 2.95.1 => 295
+ # 3.1 => 301
+ # 9 => 900
+ my @numbers = split /\./, $v;
+ my @factors = (100, 1);
+ while (@numbers && @factors) {
+ $CCVER += shift(@numbers) * shift(@factors)
+ }
+ last;
+ }
+ }
+ }
+
+ # Vendor specific overrides, only if we didn't determine the compiler here
+ if ( ! $cc ) {
+ if ( $SYSTEM eq 'OpenVMS' ) {
+ my $v = `CC/VERSION NLA0:`;
+ if ($? == 0) {
+ # The normal releases have a version number prefixed with a V.
+ # However, other letters have been seen as well (for example X),
+ # and it's documented that HP (now VSI) reserve the letter W, X,
+ # Y and Z for their own uses.
+ my ($vendor, $arch, $version, $extra) =
+ ( $v =~ m/^
+ ([A-Z]+) # Usually VSI
+ \s+ C
+ (?:\s+(.*?))? # Possible build arch
+ \s+ [VWXYZ]([0-9\.-]+) # Version
+ (?:\s+\((.*?)\))? # Possible extra data
+ \s+ on
+ /x );
+ my ($major, $minor, $patch) =
+ ( $version =~ m/^([0-9]+)\.([0-9]+)-0*?(0|[1-9][0-9]*)$/ );
+ $CC = 'CC';
+ $CCVENDOR = $vendor;
+ $CCVER = ( $major * 100 + $minor ) * 100 + $patch;
+ }
+ }
+
+ if ( ${SYSTEM} eq 'AIX' ) {
+ # favor vendor cc over gcc
+ if (IPC::Cmd::can_run('cc')) {
+ $CC = 'cc';
+ $CCVENDOR = ''; # Determine later
+ $CCVER = 0;
+ }
+ }
+
+ if ( $SYSTEM eq "SunOS" ) {
+ # check for Oracle Developer Studio, expected output is "cc: blah-blah C x.x blah-blah"
+ my $v = `(cc -V 2>&1) 2>/dev/null | egrep -e '^cc: .* C [0-9]\.[0-9]'`;
+ my @numbers =
+ ( $v =~ m/^.* C ([0-9]+)\.([0-9]+) .*/ );
+ my @factors = (100, 1);
+ $v = 0;
+ while (@numbers && @factors) {
+ $v += shift(@numbers) * shift(@factors)
+ }
+
+ if ($v > 500) {
+ $CC = 'cc';
+ $CCVENDOR = 'sun';
+ $CCVER = $v;
+ }
+ }
+
+ # 'Windows NT' is the system name according to POSIX::uname()!
+ if ( $SYSTEM eq "Windows NT" ) {
+ # favor vendor cl over gcc
+ if (IPC::Cmd::can_run('cl')) {
+ $CC = 'cl';
+ $CCVENDOR = ''; # Determine later
+ $CCVER = 0;
+
+ my $v = `cl 2>&1`;
+ if ( $v =~ /Microsoft .* Version ([0-9\.]+) for (x86|x64|ARM|ia64)/ ) {
+ $CCVER = $1;
+ $CL_ARCH = $2;
+ }
+ }
+ }
+ }
+
+ # If no C compiler has been determined at this point, we die. Hard.
+ die <<_____
+ERROR!
+No C compiler found, please specify one with the environment variable CC,
+or configure with an explicit configuration target.
+_____
+ unless $CC;
+
+ # On some systems, we assume a cc vendor if it's not already determined
+
+ if ( ! $CCVENDOR ) {
+ $CCVENDOR = 'aix' if $SYSTEM eq 'AIX';
+ $CCVENDOR = 'sun' if $SYSTEM eq 'SunOS';
+ }
+
+ # Some systems need to know extra details
+
+ if ( $SYSTEM eq "HP-UX" && $CCVENDOR eq 'gnu' ) {
+ # By default gcc is a ILP32 compiler (with long long == 64).
+ $GCC_BITS = "32";
+ if ( $CCVER >= 300 ) {
+ # PA64 support only came in with gcc 3.0.x.
+ # We check if the preprocessor symbol __LP64__ is defined.
+ if ( okrun('echo __LP64__',
+ "$CC -v -E -x c - 2>/dev/null",
+ 'grep "^__LP64__" 2>&1 >/dev/null') ) {
+ # __LP64__ has slipped through, it therefore is not defined
+ } else {
+ $GCC_BITS = '64';
+ }
+ }
+ }
+
+ if ( $SYSTEM eq "SunOS" && $CCVENDOR eq 'gnu' ) {
+ if ( $CCVER >= 300 ) {
+ # 64-bit ABI isn't officially supported in gcc 3.0, but seems
+ # to be working; at the very least 'make test' passes.
+ if ( okrun("$CC -v -E -x c /dev/null 2>&1",
+ 'grep __arch64__ >/dev/null') ) {
+ $GCC_ARCH = "-m64"
+ } else {
+ $GCC_ARCH = "-m32"
+ }
+ }
+ }
+
+ if ($VERBOSE) {
+ my $vendor = $CCVENDOR ? $CCVENDOR : "(undetermined)";
+ my $version = $CCVER ? $CCVER : "(undetermined)";
+ print "C compiler: $CC\n";
+ print "C compiler vendor: $vendor\n";
+ print "C compiler version: $version\n";
+ }
+}
+
+my $map_patterns =
+ [ [ 'uClinux.*64.*', { target => 'uClinux-dist64' } ],
+ [ 'uClinux.*', { target => 'uClinux-dist' } ],
+ [ 'mips3-sgi-irix', { target => 'irix-mips3' } ],
+ [ 'mips4-sgi-irix64',
+ sub {
+ print <<EOF;
+WARNING! To build 64-bit package, do this:
+ $WHERE/Configure irix64-mips4-$CC
+EOF
+ maybe_abort();
+ return { target => "irix-mips3" };
+ }
+ ],
+ [ 'ppc-apple-rhapsody', { target => "rhapsody-ppc" } ],
+ [ 'ppc-apple-darwin.*',
+ sub {
+ my $KERNEL_BITS = $ENV{KERNEL_BITS} // '';
+ my $ISA64 = `sysctl -n hw.optional.64bitops 2>/dev/null`;
+ if ( $ISA64 == 1 && $KERNEL_BITS eq '' ) {
+ print <<EOF;
+WARNING! To build 64-bit package, do this:
+ $WHERE/Configure darwin64-ppc-cc
+EOF
+ maybe_abort();
+ }
+ return { target => "darwin64-ppc" }
+ if $ISA64 == 1 && $KERNEL_BITS eq '64';
+ return { target => "darwin-ppc" };
+ }
+ ],
+ [ 'i.86-apple-darwin.*',
+ sub {
+ my $KERNEL_BITS = $ENV{KERNEL_BITS} // '';
+ my $ISA64 = `sysctl -n hw.optional.x86_64 2>/dev/null`;
+ if ( $ISA64 == 1 && $KERNEL_BITS eq '' ) {
+ print <<EOF;
+WARNING! To build 64-bit package, do this:
+ KERNEL_BITS=64 $WHERE/Configure \[\[ options \]\]
+EOF
+ maybe_abort();
+ }
+ return { target => "darwin64-x86_64" }
+ if $ISA64 == 1 && $KERNEL_BITS eq '64';
+ return { target => "darwin-i386" };
+ }
+ ],
+ [ 'x86_64-apple-darwin.*',
+ sub {
+ my $KERNEL_BITS = $ENV{KERNEL_BITS} // '';
+ # macOS >= 10.15 is 64-bit only
+ my $SW_VERS = `sw_vers -productVersion 2>/dev/null`;
+ if ($SW_VERS =~ /^(\d+)\.(\d+)\.(\d+)$/) {
+ if ($1 > 10 || ($1 == 10 && $2 >= 15)) {
+ die "32-bit applications not supported on macOS 10.15 or later\n" if $KERNEL_BITS eq '32';
+ return { target => "darwin64-x86_64" };
+ }
+ }
+ return { target => "darwin-i386" } if $KERNEL_BITS eq '32';
+
+ print <<EOF;
+WARNING! To build 32-bit package, do this:
+ KERNEL_BITS=32 $WHERE/Configure \[\[ options \]\]
+EOF
+ maybe_abort();
+ return { target => "darwin64-x86_64" };
+ }
+ ],
+ [ 'arm64-apple-darwin.*', { target => "darwin64-arm64" } ],
+ [ 'armv6\+7-.*-iphoneos',
+ { target => "iphoneos-cross",
+ cflags => [ qw(-arch armv6 -arch armv7) ],
+ cxxflags => [ qw(-arch armv6 -arch armv7) ] }
+ ],
+ [ 'arm64-.*-iphoneos|.*-.*-ios64',
+ { target => "ios64-cross" }
+ ],
+ [ '.*-.*-iphoneos',
+ sub { return { target => "iphoneos-cross",
+ cflags => [ "-arch ${MACHINE}" ],
+ cxxflags => [ "-arch ${MACHINE}" ] }; }
+ ],
+ [ 'alpha-.*-linux2.*',
+ sub {
+ my $ISA = `awk '/cpu model/{print \$4;exit(0);}' /proc/cpuinfo`;
+ $ISA //= 'generic';
+ my %config = ();
+ if ( $CCVENDOR eq "gnu" ) {
+ if ( $ISA =~ 'EV5|EV45' ) {
+ %config = ( cflags => [ '-mcpu=ev5' ],
+ cxxflags => [ '-mcpu=ev5' ] );
+ } elsif ( $ISA =~ 'EV56|PCA56' ) {
+ %config = ( cflags => [ '-mcpu=ev56' ],
+ cxxflags => [ '-mcpu=ev56' ] );
+ } else {
+ %config = ( cflags => [ '-mcpu=ev6' ],
+ cxxflags => [ '-mcpu=ev6' ] );
+ }
+ }
+ return { target => "linux-alpha",
+ %config };
+ }
+ ],
+ [ 'ppc64-.*-linux2',
+ sub {
+ my $KERNEL_BITS = $ENV{KERNEL_BITS} // '';
+ if ( $KERNEL_BITS eq '' ) {
+ print <<EOF;
+WARNING! To build 64-bit package, do this:
+ $WHERE/Configure linux-ppc64
+EOF
+ maybe_abort();
+ }
+ return { target => "linux-ppc64" } if $KERNEL_BITS eq '64';
+
+ my %config = ();
+ if (!okrun('echo __LP64__',
+ 'gcc -E -x c - 2>/dev/null',
+ 'grep "^__LP64__" 2>&1 >/dev/null') ) {
+ %config = ( cflags => [ '-m32' ],
+ cxxflags => [ '-m32' ] );
+ }
+ return { target => "linux-ppc",
+ %config };
+ }
+ ],
+ [ 'ppc64le-.*-linux2', { target => "linux-ppc64le" } ],
+ [ 'ppc-.*-linux2', { target => "linux-ppc" } ],
+ [ 'mips64.*-*-linux2',
+ sub {
+ print <<EOF;
+WARNING! To build 64-bit package, do this:
+ $WHERE/Configure linux64-mips64
+EOF
+ maybe_abort();
+ return { target => "linux-mips64" };
+ }
+ ],
+ [ 'mips.*-.*-linux2', { target => "linux-mips32" } ],
+ [ 'ppc60x-.*-vxworks.*', { target => "vxworks-ppc60x" } ],
+ [ 'ppcgen-.*-vxworks.*', { target => "vxworks-ppcgen" } ],
+ [ 'pentium-.*-vxworks.*', { target => "vxworks-pentium" } ],
+ [ 'simlinux-.*-vxworks.*', { target => "vxworks-simlinux" } ],
+ [ 'mips-.*-vxworks.*', { target => "vxworks-mips" } ],
+ [ 'e2k-.*-linux.*', { target => "linux-generic64",
+ defines => [ 'L_ENDIAN' ] } ],
+ [ 'ia64-.*-linux.', { target => "linux-ia64" } ],
+ [ 'sparc64-.*-linux2',
+ sub {
+ print <<EOF;
+WARNING! If you *know* that your GNU C supports 64-bit/V9 ABI and you
+ want to build 64-bit library, do this:
+ $WHERE/Configure linux64-sparcv9
+EOF
+ maybe_abort();
+ return { target => "linux-sparcv9" };
+ }
+ ],
+ [ 'sparc-.*-linux2',
+ sub {
+ my $KARCH = `awk '/^type/{print \$3;exit(0);}' /proc/cpuinfo`;
+ $KARCH //= "sun4";
+ return { target => "linux-sparcv9" } if $KARCH =~ 'sun4u.*';
+ return { target => "linux-sparcv8" } if $KARCH =~ 'sun4[md]';
+ return { target => "linux-generic32",
+ defines => [ 'L_ENDIAN' ] };
+ }
+ ],
+ [ 'parisc.*-.*-linux2',
+ sub {
+ # 64-bit builds under parisc64 linux are not supported and
+ # compiler is expected to generate 32-bit objects...
+ my $CPUARCH =
+ `awk '/cpu family/{print substr(\$5,1,3); exit(0);}' /proc/cpuinfo`;
+ my $CPUSCHEDULE =
+ `awk '/^cpu.[ ]*: PA/{print substr(\$3,3); exit(0);}' /proc/cpuinfo`;
+ # TODO XXX Model transformations
+ # 0. CPU Architecture for the 1.1 processor has letter suffixes.
+ # We strip that off assuming no further arch. identification
+ # will ever be used by GCC.
+ # 1. I'm most concerned about whether is a 7300LC is closer to a
+ # 7100 versus a 7100LC.
+ # 2. The variant 64-bit processors cause concern should GCC support
+ # explicit schedulers for these chips in the future.
+ # PA7300LC -> 7100LC (1.1)
+ # PA8200 -> 8000 (2.0)
+ # PA8500 -> 8000 (2.0)
+ # PA8600 -> 8000 (2.0)
+ $CPUSCHEDULE =~ s/7300LC/7100LC/;
+ $CPUSCHEDULE =~ s/8.00/8000/;
+ return
+ { target => "linux-generic32",
+ defines => [ 'B_ENDIAN' ],
+ cflags => [ "-mschedule=$CPUSCHEDULE", "-march=$CPUARCH" ],
+ cxxflags => [ "-mschedule=$CPUSCHEDULE", "-march=$CPUARCH" ]
+ };
+ }
+ ],
+ [ 'armv[1-3].*-.*-linux2', { target => "linux-generic32" } ],
+ [ 'armv[7-9].*-.*-linux2', { target => "linux-armv4",
+ cflags => [ '-march=armv7-a' ],
+ cxxflags => [ '-march=armv7-a' ] } ],
+ [ 'arm.*-.*-linux2', { target => "linux-armv4" } ],
+ [ 'aarch64-.*-linux2', { target => "linux-aarch64" } ],
+ [ 'sh.*b-.*-linux2', { target => "linux-generic32",
+ defines => [ 'B_ENDIAN' ] } ],
+ [ 'sh.*-.*-linux2', { target => "linux-generic32",
+ defines => [ 'L_ENDIAN' ] } ],
+ [ 'm68k.*-.*-linux2', { target => "linux-generic32",
+ defines => [ 'B_ENDIAN' ] } ],
+ [ 's390-.*-linux2', { target => "linux-generic32",
+ defines => [ 'B_ENDIAN' ] } ],
+ [ 's390x-.*-linux2',
+ sub {
+ # Disabled until a glibc bug is fixed; see Configure.
+ if (0
+ || okrun('egrep -e \'^features.* highgprs\' /proc/cpuinfo >/dev/null') )
+ {
+ print <<EOF;
+WARNING! To build "highgprs" 32-bit package, do this:
+ $WHERE/Configure linux32-s390x
+EOF
+ maybe_abort();
+ }
+ return { target => "linux64-s390x" };
+ }
+ ],
+ [ 'x86_64-.*-linux.',
+ sub {
+ return { target => "linux-x32" }
+ if okrun("$CC -dM -E -x c /dev/null 2>&1",
+ 'grep -q ILP32 >/dev/null');
+ return { target => "linux-x86_64" };
+ }
+ ],
+ [ '.*86-.*-linux2',
+ sub {
+ # On machines where the compiler understands -m32, prefer a
+ # config target that uses it
+ return { target => "linux-x86" }
+ if okrun("$CC -m32 -E -x c /dev/null >/dev/null 2>&1");
+ return { target => "linux-elf" };
+ }
+ ],
+ [ '.*86-.*-linux1', { target => "linux-aout" } ],
+ [ 'riscv64-.*-linux.', { target => "linux64-riscv64" } ],
+ [ '.*-.*-linux.', { target => "linux-generic32" } ],
+ [ 'sun4[uv].*-.*-solaris2',
+ sub {
+ my $KERNEL_BITS = $ENV{KERNEL_BITS};
+ my $ISA64 = `isainfo 2>/dev/null | grep sparcv9`;
+ my $KB = $KERNEL_BITS // '64';
+ if ( $ISA64 ne "" && $KB eq '64' ) {
+ if ( $CCVENDOR eq "sun" && $CCVER >= 500 ) {
+ print <<EOF;
+WARNING! To build 32-bit package, do this:
+ $WHERE/Configure solaris-sparcv9-cc
+EOF
+ maybe_abort();
+ } elsif ( $CCVENDOR eq "gnu" && $GCC_ARCH eq "-m64" ) {
+ # $GCC_ARCH denotes default ABI chosen by compiler driver
+ # (first one found on the $PATH). I assume that user
+ # expects certain consistency with the rest of his builds
+ # and therefore switch over to 64-bit. <appro>
+ print <<EOF;
+WARNING! To build 32-bit package, do this:
+ $WHERE/Configure solaris-sparcv9-gcc
+EOF
+ maybe_abort();
+ return { target => "solaris64-sparcv9-gcc" };
+ } elsif ( $GCC_ARCH eq "-m32" ) {
+ print <<EOF;
+NOTICE! If you *know* that your GNU C supports 64-bit/V9 ABI and you wish
+ to build 64-bit library, do this:
+ $WHERE/Configure solaris64-sparcv9-gcc
+EOF
+ maybe_abort();
+ }
+ }
+ return { target => "solaris64-sparcv9-cc" }
+ if $ISA64 ne "" && $KB eq '64';
+ return { target => "solaris-sparcv9-cc" };
+ }
+ ],
+ [ 'sun4m-.*-solaris2', { target => "solaris-sparcv8" } ],
+ [ 'sun4d-.*-solaris2', { target => "solaris-sparcv8" } ],
+ [ 'sun4.*-.*-solaris2', { target => "solaris-sparcv7" } ],
+ [ '.*86.*-.*-solaris2',
+ sub {
+ my $KERNEL_BITS = $ENV{KERNEL_BITS};
+ my $ISA64 = `isainfo 2>/dev/null | grep amd64`;
+ my $KB = $KERNEL_BITS // '64';
+ if ($ISA64 ne "" && $KB eq '64') {
+ return { target => "solaris64-x86_64-gcc" } if $CCVENDOR eq "gnu";
+ return { target => "solaris64-x86_64-cc" };
+ }
+ my $REL = uname('-r');
+ $REL =~ s/5\.//;
+ my @tmp_disable = ();
+ push @tmp_disable, 'sse2' if int($REL) < 10;
+ #There is no solaris-x86-cc target
+ return { target => "solaris-x86-gcc",
+ disable => [ @tmp_disable ] };
+ }
+ ],
+ # We don't have any sunos target in Configurations/*.conf, so why here?
+ [ '.*-.*-sunos4', { target => "sunos" } ],
+ [ '.*86.*-.*-bsdi4', { target => "BSD-x86-elf",
+ lflags => [ '-ldl' ],
+ disable => [ 'sse2' ] } ],
+ [ 'alpha.*-.*-.*bsd.*', { target => "BSD-generic64",
+ defines => [ 'L_ENDIAN' ] } ],
+ [ 'powerpc64-.*-.*bsd.*', { target => "BSD-generic64",
+ defines => [ 'B_ENDIAN' ] } ],
+ [ 'riscv64-.*-.*bsd.*', { target => "BSD-riscv64" } ],
+ [ 'sparc64-.*-.*bsd.*', { target => "BSD-sparc64" } ],
+ [ 'ia64-.*-.*bsd.*', { target => "BSD-ia64" } ],
+ [ 'x86_64-.*-dragonfly.*', { target => "BSD-x86_64" } ],
+ [ 'amd64-.*-.*bsd.*', { target => "BSD-x86_64" } ],
+ [ 'arm64-.*-.*bsd.*', { target => "BSD-aarch64" } ],
+ [ '.*86.*-.*-.*bsd.*',
+ sub {
+ # mimic ld behaviour when it's looking for libc...
+ my $libc;
+ if ( -l "/usr/lib/libc.so" ) {
+ $libc = "/usr/lib/libc.so";
+ } else {
+ # ld searches for highest libc.so.* and so do we
+ $libc =
+ `(ls /usr/lib/libc.so.* /lib/libc.so.* | tail -1) 2>/dev/null`;
+ }
+ my $what = `file -L $libc 2>/dev/null`;
+ return { target => "BSD-x86-elf" } if $what =~ /ELF/;
+ return { target => "BSD-x86",
+ disable => [ 'sse2' ] };
+ }
+ ],
+ [ '.*-.*-.*bsd.*', { target => "BSD-generic32" } ],
+ [ 'x86_64-.*-haiku', { target => "haiku-x86_64" } ],
+ [ '.*-.*-haiku', { target => "haiku-x86" } ],
+ [ '.*-.*-osf', { target => "osf1-alpha" } ],
+ [ '.*-.*-tru64', { target => "tru64-alpha" } ],
+ [ '.*-.*-[Uu]nix[Ww]are7',
+ sub {
+ return { target => "unixware-7",
+ disable => [ 'sse2' ] } if $CCVENDOR eq "gnu";
+ return { target => "unixware-7",
+ defines => [ '__i386__' ] };
+ }
+ ],
+ [ '.*-.*-[Uu]nix[Ww]are20.*', { target => "unixware-2.0",
+ disable => [ 'sse2', 'sha512' ] } ],
+ [ '.*-.*-[Uu]nix[Ww]are21.*', { target => "unixware-2.1",
+ disable => [ 'sse2', 'sha512' ] } ],
+ [ '.*-.*-vos', { target => "vos",
+ disable => [ 'threads', 'shared', 'asm',
+ 'dso' ] } ],
+ [ 'BS2000-siemens-sysv4', { target => "BS2000-OSD" } ],
+ [ 'i[3456]86-.*-cygwin', { target => "Cygwin-x86" } ],
+ [ '.*-.*-cygwin',
+ sub { return { target => "Cygwin-${MACHINE}" } } ],
+ [ 'x86-.*-android|i.86-.*-android', { target => "android-x86" } ],
+ [ 'armv[7-9].*-.*-android', { target => "android-armeabi",
+ cflags => [ '-march=armv7-a' ],
+ cxxflags => [ '-march=armv7-a' ] } ],
+ [ 'arm.*-.*-android', { target => "android-armeabi" } ],
+ [ '.*-hpux1.*',
+ sub {
+ my $KERNEL_BITS = $ENV{KERNEL_BITS};
+ my %common_return = ( defines => [ '_REENTRANT' ] );
+ $KERNEL_BITS ||= `getconf KERNEL_BITS 2>/dev/null` // '32';
+ # See <sys/unistd.h> for further info on CPU_VERSION.
+ my $CPU_VERSION = `getconf CPU_VERSION 2>/dev/null` // 0;
+ if ( $CPU_VERSION >= 768 ) {
+ # IA-64 CPU
+ return { target => "hpux64-ia64",
+ %common_return }
+ if $KERNEL_BITS eq '64' && ! $CCVENDOR;
+ return { target => "hpux-ia64",
+ %common_return };
+ }
+ if ( $CPU_VERSION >= 532 ) {
+ # PA-RISC 2.x CPU
+ # PA-RISC 2.0 is no longer supported as separate 32-bit
+ # target. This is compensated for by run-time detection
+ # in most critical assembly modules and taking advantage
+ # of 2.0 architecture in PA-RISC 1.1 build.
+ my $target = ($CCVENDOR eq "gnu" && $GCC_BITS eq '64')
+ ? "hpux64-parisc2"
+ : "hpux-parisc1_1";
+ if ( $KERNEL_BITS eq '64' && ! $CCVENDOR ) {
+ print <<EOF;
+WARNING! To build 64-bit package, do this:
+ $WHERE/Configure hpux64-parisc2-cc
+EOF
+ maybe_abort();
+ }
+ return { target => $target,
+ %common_return };
+ }
+ # PA-RISC 1.1+ CPU?
+ return { target => "hpux-parisc1_1",
+ %common_return } if $CPU_VERSION >= 528;
+ # PA-RISC 1.0 CPU
+ return { target => "hpux-parisc",
+ %common_return } if $CPU_VERSION >= 523;
+ # Motorola(?) CPU
+ return { target => "hpux",
+ %common_return };
+ }
+ ],
+ [ '.*-hpux', { target => "hpux-parisc" } ],
+ [ '.*-aix',
+ sub {
+ my %config = ();
+ my $KERNEL_BITS = $ENV{KERNEL_BITS};
+ $KERNEL_BITS ||= `getconf KERNEL_BITMODE 2>/dev/null`;
+ $KERNEL_BITS ||= '32';
+ my $OBJECT_MODE = $ENV{OBJECT_MODE};
+ $OBJECT_MODE ||= 32;
+ $config{target} = "aix";
+ if ( $OBJECT_MODE == 64 ) {
+ print 'Your $OBJECT_MODE was found to be set to 64';
+ $config{target} = "aix64";
+ } else {
+ if ( $CCVENDOR ne 'gnu' && $KERNEL_BITS eq '64' ) {
+ print <<EOF;
+WARNING! To build 64-bit package, do this:
+ $WHERE/Configure aix64-cc
+EOF
+ maybe_abort();
+ }
+ }
+ if ( okrun(
+ "(lsattr -E -O -l `lsdev -c processor|awk '{print \$1;exit}'`",
+ 'grep -i powerpc) >/dev/null 2>&1') ) {
+ # this applies even to Power3 and later, as they return
+ # PowerPC_POWER[345]
+ } else {
+ $config{disable} = [ 'asm' ];
+ }
+ return { %config };
+ }
+ ],
+
+ # Windows values found by looking at Perl 5's win32/win32.c
+ [ '(amd64|ia64|x86|ARM)-.*?-Windows NT',
+ sub {
+ # If we determined the arch by asking cl, take that value,
+ # otherwise the SYSTEM we got from from POSIX::uname().
+ my $arch = $CL_ARCH // $1;
+ my $config;
+
+ if ($arch) {
+ $config = { 'amd64' => { target => 'VC-WIN64A' },
+ 'ia64' => { target => 'VC-WIN64I' },
+ 'x86' => { target => 'VC-WIN32' },
+ 'x64' => { target => 'VC-WIN64A' },
+ 'ARM' => { target => 'VC-WIN64-ARM' },
+ } -> {$arch};
+ die <<_____ unless defined $config;
+ERROR
+I do not know how to handle ${arch}.
+_____
+ }
+ die <<_____ unless defined $config;
+ERROR
+Could not figure out the architecture.
+_____
+
+ return $config;
+ }
+ ],
+
+ # VMS values found by observation on existing machinery.
+ [ 'VMS_AXP-.*?-OpenVMS', { target => 'vms-alpha' } ],
+ [ 'VMS_IA64-.*?-OpenVMS', { target => 'vms-ia64' } ],
+ [ 'VMS_x86_64-.*?-OpenVMS', { target => 'vms-x86_64' } ],
+
+ # TODO: There are a few more choices among OpenSSL config targets, but
+ # reaching them involves a bit more than just a host tripet. Select
+ # environment variables could do the job to cover for more granular
+ # build options such as data model (ILP32 or LP64), thread support
+ # model (PUT, SPT or nothing), target execution environment (OSS or
+ # GUARDIAN). And still, there must be some kind of default when
+ # nothing else is said.
+ #
+ # nsv is a virtual x86 environment, equivalent to nsx, so we enforce
+ # the latter.
+ [ 'nse-tandem-nsk.*', { target => 'nonstop-nse' } ],
+ [ 'nsv-tandem-nsk.*', { target => 'nonstop-nsx' } ],
+ [ 'nsx-tandem-nsk.*', { target => 'nonstop-nsx' } ],
+
+ ];
+
+# Map GUESSOS into OpenSSL terminology.
+# Returns a hash table with diverse entries, most importantly 'target',
+# but also other entries that are fitting for Configure's %config
+# and MACHINE.
+# It would be nice to fix this so that this weren't necessary. :( XXX
+sub map_guess {
+ my $GUESSOS = shift;
+
+ foreach my $tuple ( @$map_patterns ) {
+ my $pat = @$tuple[0];
+ next if $GUESSOS !~ /^${pat}$/;
+ my $result = @$tuple[1];
+ $result = $result->() if ref $result eq 'CODE';
+ return %$result;
+ }
+
+ # Last case, return "z" from x-y-z
+ my @fields = split(/-/, $GUESSOS);
+ return ( target => $fields[2] );
+}
+
+# gcc < 2.8 does not support -march=ultrasparc
+sub check_solaris_sparc8 {
+ my $OUT = shift;
+ if ( $CCVENDOR eq 'gnu' && $CCVER < 208 ) {
+ if ( $OUT eq 'solaris-sparcv9-gcc' ) {
+ print <<EOF;
+WARNING! Downgrading to solaris-sparcv8-gcc
+ Upgrade to gcc-2.8 or later.
+EOF
+ maybe_abort();
+ return 'solaris-sparcv8-gcc';
+ }
+ if ( $OUT eq "linux-sparcv9" ) {
+ print <<EOF;
+WARNING! Downgrading to linux-sparcv8
+ Upgrade to gcc-2.8 or later.
+EOF
+ maybe_abort();
+ return 'linux-sparcv8';
+ }
+ }
+ return $OUT;
+}
+
+###
+### MAIN PROCESSING
+###
+
+sub get_platform {
+ my %options = @_;
+
+ $VERBOSE = 1 if defined $options{verbose};
+ $WAIT = 0 if defined $options{nowait};
+ $CC = $options{CC};
+ $CROSS_COMPILE = $options{CROSS_COMPILE} // '';
+
+ my $GUESSOS = guess_system();
+ determine_compiler_settings();
+
+ my %ret = map_guess($GUESSOS);
+ $ret{target} = check_solaris_sparc8($ret{target});
+ return %ret;
+}
+
+1;
diff --git a/util/perl/OpenSSL/copyright.pm b/util/perl/OpenSSL/copyright.pm
new file mode 100644
index 000000000000..87567c088945
--- /dev/null
+++ b/util/perl/OpenSSL/copyright.pm
@@ -0,0 +1,43 @@
+#! /usr/bin/env perl
+# Copyright 2021-2022 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
+
+use strict;
+use warnings;
+
+package OpenSSL::copyright;
+
+sub year_of {
+ my $file = shift;
+
+ return $ENV{'OSSL_COPYRIGHT_YEAR'} if defined $ENV{'OSSL_COPYRIGHT_YEAR'};
+
+ # Get the current year. We use that as the default because the other
+ # common case is that someone unpacked a tarfile and the file dates
+ # are't properly set on extract.
+ my $YEAR = [localtime()]->[5] + 1900;
+
+ # See if git's available
+ open my $FH,
+ "git log -1 --date=short --format=format:%cd $file 2>/dev/null|"
+ or return $YEAR;
+ my $LINE = <$FH>;
+ close $FH;
+ $LINE =~ s/^([0-9]*)-.*/$1/;
+ $YEAR = $LINE if $LINE;
+ return $YEAR;
+}
+
+sub latest {
+ my $l = 0;
+ foreach my $f (@_ ) {
+ my $y = year_of($f);
+ $l = $y if $y > $l;
+ }
+ return $l
+}
+1;
diff --git a/util/perl/OpenSSL/fallback.pm b/util/perl/OpenSSL/fallback.pm
new file mode 100644
index 000000000000..d4b5785cfc0b
--- /dev/null
+++ b/util/perl/OpenSSL/fallback.pm
@@ -0,0 +1,127 @@
+# Copyright 2019-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
+
+=head1 NAME
+
+OpenSSL::fallback - push directories to the end of @INC at compile time
+
+=cut
+
+package OpenSSL::fallback;
+
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.01';
+
+=head1 SYNOPSIS
+
+ use OpenSSL::fallback LIST;
+
+=head1 DESCRIPTION
+
+This small simple module simplifies the addition of fallback directories
+in @INC at compile time.
+
+It is used to add extra directories at the end of perl's search path so
+that later "use" or "require" statements will find modules which are not
+located on perl's default search path.
+
+This is similar to L<lib>, except the paths are I<appended> to @INC rather
+than prepended, thus allowing the use of a newer module on perl's default
+search path if there is one.
+
+=head1 CAVEAT
+
+Just like with B<lib>, this only works with Unix filepaths.
+Just like with L<lib>, this doesn't mean that it only works on Unix, but that
+non-Unix users must first translate their file paths to Unix conventions.
+
+ # VMS users wanting to put [.my.stuff] into their @INC should write:
+ use fallback 'my/stuff';
+
+=head1 NOTES
+
+If you try to add a file to @INC as follows, you will be warned, and the file
+will be ignored:
+
+ use fallback 'file.txt';
+
+The sole exception is the file F<MODULES.txt>, which must contain a list of
+sub-directories relative to the location of that F<MODULES.txt> file.
+All these sub-directories will be appended to @INC.
+
+=cut
+
+# Forward declare
+sub glob;
+
+use constant DEBUG => 0;
+
+sub import {
+ shift; # Skip module name
+
+ foreach (@_) {
+ my $path = $_;
+
+ if ($path eq '') {
+ carp "Empty compile time value given to use fallback";
+ next;
+ }
+
+ print STDERR "DEBUG: $path\n" if DEBUG;
+
+ unless (-e $path
+ && ($path =~ m/(?:^|\/)MODULES.txt/ || -d $path)) {
+ croak "Parameter to use fallback must be a directory, not a file";
+ next;
+ }
+
+ my @dirs = ();
+ if (-f $path) { # It's a MODULES.txt file
+ (my $dir = $path) =~ s|/[^/]*$||; # quick dirname
+ open my $fh, $path or die "Could not open $path: $!\n";
+ while (my $l = <$fh>) {
+ $l =~ s|\R$||; # Better chomp
+ my $d = "$dir/$l";
+ my $checked = $d;
+
+ if ($^O eq 'VMS') {
+ # Some VMS unpackers replace periods with underscores
+ # We must be real careful not to convert the directories
+ # '.' and '..', though.
+ $checked =
+ join('/',
+ map { my $x = $_;
+ $x =~ s|\.|_|g
+ if ($x ne '..' && $x ne '.');
+ $x }
+ split(m|/|, $checked))
+ unless -e $checked && -d $checked;
+ }
+ croak "All lines in $path must be a directory, not a file: $l"
+ unless -e $checked && -d $checked;
+ push @INC, $checked;
+ }
+ } else { # It's a directory
+ push @INC, $path;
+ }
+ }
+}
+
+=head1 SEE ALSO
+
+L<FindBin> - optional module which deals with paths relative to the source
+file.
+
+=head1 AUTHOR
+
+Richard Levitte, 2019
+
+=cut
+
diff --git a/util/perl/OpenSSL/stackhash.pm b/util/perl/OpenSSL/stackhash.pm
new file mode 100644
index 000000000000..4d59eab0c937
--- /dev/null
+++ b/util/perl/OpenSSL/stackhash.pm
@@ -0,0 +1,106 @@
+#! /usr/bin/env perl
+# Copyright 2020-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::stackhash;
+
+use strict;
+use warnings;
+
+require Exporter;
+our @ISA = qw(Exporter);
+our @EXPORT_OK = qw(generate_stack_macros generate_const_stack_macros
+ generate_stack_string_macros
+ generate_stack_const_string_macros
+ generate_stack_block_macros
+ generate_lhash_macros);
+
+sub generate_stack_macros_int {
+ my $nametype = shift;
+ my $realtype = shift;
+ my $plaintype = shift;
+
+ my $macros = <<END_MACROS;
+SKM_DEFINE_STACK_OF_INTERNAL(${nametype}, ${realtype}, ${plaintype})
+#define sk_${nametype}_num(sk) OPENSSL_sk_num(ossl_check_const_${nametype}_sk_type(sk))
+#define sk_${nametype}_value(sk, idx) ((${realtype} *)OPENSSL_sk_value(ossl_check_const_${nametype}_sk_type(sk), (idx)))
+#define sk_${nametype}_new(cmp) ((STACK_OF(${nametype}) *)OPENSSL_sk_new(ossl_check_${nametype}_compfunc_type(cmp)))
+#define sk_${nametype}_new_null() ((STACK_OF(${nametype}) *)OPENSSL_sk_new_null())
+#define sk_${nametype}_new_reserve(cmp, n) ((STACK_OF(${nametype}) *)OPENSSL_sk_new_reserve(ossl_check_${nametype}_compfunc_type(cmp), (n)))
+#define sk_${nametype}_reserve(sk, n) OPENSSL_sk_reserve(ossl_check_${nametype}_sk_type(sk), (n))
+#define sk_${nametype}_free(sk) OPENSSL_sk_free(ossl_check_${nametype}_sk_type(sk))
+#define sk_${nametype}_zero(sk) OPENSSL_sk_zero(ossl_check_${nametype}_sk_type(sk))
+#define sk_${nametype}_delete(sk, i) ((${realtype} *)OPENSSL_sk_delete(ossl_check_${nametype}_sk_type(sk), (i)))
+#define sk_${nametype}_delete_ptr(sk, ptr) ((${realtype} *)OPENSSL_sk_delete_ptr(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_type(ptr)))
+#define sk_${nametype}_push(sk, ptr) OPENSSL_sk_push(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_type(ptr))
+#define sk_${nametype}_unshift(sk, ptr) OPENSSL_sk_unshift(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_type(ptr))
+#define sk_${nametype}_pop(sk) ((${realtype} *)OPENSSL_sk_pop(ossl_check_${nametype}_sk_type(sk)))
+#define sk_${nametype}_shift(sk) ((${realtype} *)OPENSSL_sk_shift(ossl_check_${nametype}_sk_type(sk)))
+#define sk_${nametype}_pop_free(sk, freefunc) OPENSSL_sk_pop_free(ossl_check_${nametype}_sk_type(sk),ossl_check_${nametype}_freefunc_type(freefunc))
+#define sk_${nametype}_insert(sk, ptr, idx) OPENSSL_sk_insert(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_type(ptr), (idx))
+#define sk_${nametype}_set(sk, idx, ptr) ((${realtype} *)OPENSSL_sk_set(ossl_check_${nametype}_sk_type(sk), (idx), ossl_check_${nametype}_type(ptr)))
+#define sk_${nametype}_find(sk, ptr) OPENSSL_sk_find(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_type(ptr))
+#define sk_${nametype}_find_ex(sk, ptr) OPENSSL_sk_find_ex(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_type(ptr))
+#define sk_${nametype}_find_all(sk, ptr, pnum) OPENSSL_sk_find_all(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_type(ptr), pnum)
+#define sk_${nametype}_sort(sk) OPENSSL_sk_sort(ossl_check_${nametype}_sk_type(sk))
+#define sk_${nametype}_is_sorted(sk) OPENSSL_sk_is_sorted(ossl_check_const_${nametype}_sk_type(sk))
+#define sk_${nametype}_dup(sk) ((STACK_OF(${nametype}) *)OPENSSL_sk_dup(ossl_check_const_${nametype}_sk_type(sk)))
+#define sk_${nametype}_deep_copy(sk, copyfunc, freefunc) ((STACK_OF(${nametype}) *)OPENSSL_sk_deep_copy(ossl_check_const_${nametype}_sk_type(sk), ossl_check_${nametype}_copyfunc_type(copyfunc), ossl_check_${nametype}_freefunc_type(freefunc)))
+#define sk_${nametype}_set_cmp_func(sk, cmp) ((sk_${nametype}_compfunc)OPENSSL_sk_set_cmp_func(ossl_check_${nametype}_sk_type(sk), ossl_check_${nametype}_compfunc_type(cmp)))
+END_MACROS
+
+ return $macros;
+}
+
+sub generate_stack_macros {
+ my $type = shift;
+
+ return generate_stack_macros_int($type, $type, $type);
+}
+
+sub generate_const_stack_macros {
+ my $type = shift;
+
+ return generate_stack_macros_int($type, "const $type", $type);
+}
+
+sub generate_stack_string_macros {
+ return generate_stack_macros_int("OPENSSL_STRING", "char", "char");
+}
+
+sub generate_stack_const_string_macros {
+ return generate_stack_macros_int("OPENSSL_CSTRING", "const char", "char");
+}
+
+sub generate_stack_block_macros {
+ return generate_stack_macros_int("OPENSSL_BLOCK", "void", "void");
+}
+
+sub generate_lhash_macros {
+ my $type = shift;
+
+ my $macros = <<END_MACROS;
+DEFINE_LHASH_OF_INTERNAL(${type});
+#define lh_${type}_new(hfn, cmp) ((LHASH_OF(${type}) *)OPENSSL_LH_new(ossl_check_${type}_lh_hashfunc_type(hfn), ossl_check_${type}_lh_compfunc_type(cmp)))
+#define lh_${type}_free(lh) OPENSSL_LH_free(ossl_check_${type}_lh_type(lh))
+#define lh_${type}_flush(lh) OPENSSL_LH_flush(ossl_check_${type}_lh_type(lh))
+#define lh_${type}_insert(lh, ptr) ((${type} *)OPENSSL_LH_insert(ossl_check_${type}_lh_type(lh), ossl_check_${type}_lh_plain_type(ptr)))
+#define lh_${type}_delete(lh, ptr) ((${type} *)OPENSSL_LH_delete(ossl_check_${type}_lh_type(lh), ossl_check_const_${type}_lh_plain_type(ptr)))
+#define lh_${type}_retrieve(lh, ptr) ((${type} *)OPENSSL_LH_retrieve(ossl_check_${type}_lh_type(lh), ossl_check_const_${type}_lh_plain_type(ptr)))
+#define lh_${type}_error(lh) OPENSSL_LH_error(ossl_check_${type}_lh_type(lh))
+#define lh_${type}_num_items(lh) OPENSSL_LH_num_items(ossl_check_${type}_lh_type(lh))
+#define lh_${type}_node_stats_bio(lh, out) OPENSSL_LH_node_stats_bio(ossl_check_const_${type}_lh_type(lh), out)
+#define lh_${type}_node_usage_stats_bio(lh, out) OPENSSL_LH_node_usage_stats_bio(ossl_check_const_${type}_lh_type(lh), out)
+#define lh_${type}_stats_bio(lh, out) OPENSSL_LH_stats_bio(ossl_check_const_${type}_lh_type(lh), out)
+#define lh_${type}_get_down_load(lh) OPENSSL_LH_get_down_load(ossl_check_${type}_lh_type(lh))
+#define lh_${type}_set_down_load(lh, dl) OPENSSL_LH_set_down_load(ossl_check_${type}_lh_type(lh), dl)
+#define lh_${type}_doall(lh, dfn) OPENSSL_LH_doall(ossl_check_${type}_lh_type(lh), ossl_check_${type}_lh_doallfunc_type(dfn))
+END_MACROS
+
+ return $macros;
+}
+1;
generated by cgit v1.2.3 (git 2.25.1) at 2025-06-10 21:31:32 +0000