[openssl-commits] [openssl] master update
Richard Levitte
levitte at openssl.org
Thu Oct 4 10:49:33 UTC 2018
The branch master has been updated
via 30699aa1943b10b265c52334d9f582c04c4eccba (commit)
via 15ba109631254b98d3ef2611a1765e75442314a6 (commit)
via d73c44404d470424aa58e85fe38b97351f112bc1 (commit)
via ab1e5495e45708f43f71e1f9e8872066dc8177c0 (commit)
via 8effd8fa67689e1d4318cfda21604eef428a37cf (commit)
via 91a99748d328164ab043cf7bc3da8e45ec0de497 (commit)
from 18958cefd82449daf3c589b74a074f0c88159d47 (commit)
- Log -----------------------------------------------------------------
commit 30699aa1943b10b265c52334d9f582c04c4eccba
Author: Richard Levitte <levitte at openssl.org>
Date: Fri Sep 14 15:28:39 2018 +0200
Refactor util/mknum.pl for clearer separation of functionality
Rewrite util/mknum.pl to become cleaner, and to use the separate
generic C header parsing module, as well as the separate ordinals
manipulation module.
Adapt the build files.
Reviewed-by: Tim Hudson <tjh at openssl.org>
(Merged from https://github.com/openssl/openssl/pull/7191)
commit 15ba109631254b98d3ef2611a1765e75442314a6
Author: Richard Levitte <levitte at openssl.org>
Date: Wed Oct 3 17:44:59 2018 +0200
Add code to manipulate the items in OpenSSL::Ordinals
This means adding the capability to add new items, to invalidate and
revalidate all the items, and to update the file it came from, as well
as the possibility to create new items from other data than a line
from said file.
While we're at it, we throw in a couple of useful filters.
Reviewed-by: Tim Hudson <tjh at openssl.org>
(Merged from https://github.com/openssl/openssl/pull/7191)
commit d73c44404d470424aa58e85fe38b97351f112bc1
Author: Richard Levitte <levitte at openssl.org>
Date: Wed Oct 3 17:43:48 2018 +0200
A perl module to parse through C headers
OpenSSL::ParseC is a module that parses through a C header file and
returns a list with information on what it found. Currently, the
information it returns covers function and variable declarations,
macro definitions, struct declarations/definitions and typedef
definitions.
Reviewed-by: Tim Hudson <tjh at openssl.org>
(Merged from https://github.com/openssl/openssl/pull/7191)
commit ab1e5495e45708f43f71e1f9e8872066dc8177c0
Author: Richard Levitte <levitte at openssl.org>
Date: Fri Sep 14 15:19:37 2018 +0200
Move ZLIB from 'platforms' to 'features'
Having it as a 'platform' was conceptually wrong from from the
beginning, and makes decoding more complicated than necessary.
Reviewed-by: Tim Hudson <tjh at openssl.org>
(Merged from https://github.com/openssl/openssl/pull/7191)
commit 8effd8fa67689e1d4318cfda21604eef428a37cf
Author: Richard Levitte <levitte at openssl.org>
Date: Fri Sep 14 14:59:40 2018 +0200
Refactor util/mkdef.pl for clearer separation of functionality
Move the .num updating functionality to util/mknum.pl.
Rewrite util/mkdef.pl to create .def / .map / .opt files exclusively,
using the separate ordinals reading module.
Adapt the build files.
Adapt the symbol presence test.
Reviewed-by: Tim Hudson <tjh at openssl.org>
(Merged from https://github.com/openssl/openssl/pull/7191)
commit 91a99748d328164ab043cf7bc3da8e45ec0de497
Author: Richard Levitte <levitte at openssl.org>
Date: Fri Sep 14 14:58:11 2018 +0200
Add a perl module that deals with ordinals files
Reviewed-by: Tim Hudson <tjh at openssl.org>
(Merged from https://github.com/openssl/openssl/pull/7191)
-----------------------------------------------------------------------
Summary of changes:
Configurations/descrip.mms.tmpl | 2 +-
Configurations/unix-Makefile.tmpl | 44 +-
Configurations/windows-makefile.tmpl | 2 +-
build.info | 6 +-
test/recipes/01-test_symbol_presence.t | 5 +-
util/libcrypto.num | 2 +-
util/mkdef.pl | 1824 +++++---------------------------
util/mknum.pl | 125 +++
util/perl/OpenSSL/Ordinals.pm | 946 +++++++++++++++++
util/perl/OpenSSL/ParseC.pm | 1129 ++++++++++++++++++++
10 files changed, 2540 insertions(+), 1545 deletions(-)
create mode 100644 util/mknum.pl
create mode 100644 util/perl/OpenSSL/Ordinals.pm
create mode 100644 util/perl/OpenSSL/ParseC.pm
diff --git a/Configurations/descrip.mms.tmpl b/Configurations/descrip.mms.tmpl
index 7393e22..c5dee22 100644
--- a/Configurations/descrip.mms.tmpl
+++ b/Configurations/descrip.mms.tmpl
@@ -760,7 +760,7 @@ reconfigure reconf :
my $mkdef = sourcefile('util', 'mkdef.pl');
return <<"EOF";
$target : $args{generator}->[0] $deps
- \$(PERL) $mkdef $args{generator}->[1] "VMS" > $target
+ \$(PERL) $mkdef --ordinals $args{generator}->[0] --name $args{generator}->[1] "--OS" "VMS" > $target
EOF
} elsif ($target !~ /\.[sS]$/) {
my $target = $args{src};
diff --git a/Configurations/unix-Makefile.tmpl b/Configurations/unix-Makefile.tmpl
index f67eae5..662fb05 100644
--- a/Configurations/unix-Makefile.tmpl
+++ b/Configurations/unix-Makefile.tmpl
@@ -809,9 +809,47 @@ errors:
-conf $$E `basename $$E .ec`.c ; \
done )
+{- use File::Basename;
+
+ our @sslheaders =
+ qw( include/openssl/ssl.h
+ include/openssl/ssl2.h
+ include/openssl/ssl3.h
+ include/openssl/sslerr.h
+ include/openssl/tls1.h
+ include/openssl/dtls1.h
+ include/openssl/srtp.h );
+ our @cryptoheaders =
+ qw( include/internal/dso.h
+ include/internal/o_dir.h
+ include/internal/o_str.h
+ include/internal/err.h
+ include/internal/sslconf.h );
+ our @cryptoskipheaders = ( @sslheaders,
+ qw( include/openssl/conf_api.h
+ include/openssl/ebcdic.h
+ include/openssl/opensslconf.h
+ include/openssl/symhacks.h ) );
+ foreach my $f ( glob(catfile($config{sourcedir},
+ 'include','openssl','*.h')) ) {
+ my $fn = "include/openssl/" . basename($f);
+ push @cryptoheaders, $fn unless grep { $_ eq $fn } @cryptoskipheaders;
+ }
+ "";
+-}
+CRYPTOHEADERS={- join(" \\\n\t", sort @cryptoheaders) -}
+SSLHEADERS={- join(" \\\n\t", sort @sslheaders) -}
ordinals:
- ( b=`pwd`; cd $(SRCDIR); $(PERL) -I$$b util/mkdef.pl crypto update )
- ( b=`pwd`; cd $(SRCDIR); $(PERL) -I$$b util/mkdef.pl ssl update )
+ ( cd $(SRCDIR); \
+ $(PERL) util/mknum.pl --version $(VERSION) --no-warnings \
+ --ordinals util/libcrypto.num \
+ --symhacks include/openssl/symhacks.h \
+ $(CRYPTOHEADERS) )
+ ( cd $(SRCDIR); \
+ $(PERL) util/mknum.pl --version $(VERSION) --no-warnings \
+ --ordinals util/libssl.num \
+ --symhacks include/openssl/symhacks.h \
+ $(SSLHEADERS))
test_ordinals:
( cd test; \
@@ -965,7 +1003,7 @@ reconfigure reconf:
(my $mkdef_os = $target{shared_target}) =~ s|-shared$||;
return <<"EOF";
$target: $args{generator}->[0] $deps
- \$(PERL) \$(SRCDIR)/util/mkdef.pl $args{generator}->[1] $mkdef_os > $target
+ \$(PERL) \$(SRCDIR)/util/mkdef.pl --ordinals $args{generator}->[0] --name $args{generator}->[1] --OS $mkdef_os > $target
EOF
} elsif ($args{src} !~ /\.[sS]$/) {
if ($args{generator}->[0] =~ m|^.*\.in$|) {
diff --git a/Configurations/windows-makefile.tmpl b/Configurations/windows-makefile.tmpl
index fb7ddca..46f564d 100644
--- a/Configurations/windows-makefile.tmpl
+++ b/Configurations/windows-makefile.tmpl
@@ -514,7 +514,7 @@ reconfigure reconf:
rel2abs($config{builddir}));
return <<"EOF";
$target: $args{generator}->[0] $deps
- \$(PERL) $mkdef $args{generator}->[1] 32 > $target
+ \$(PERL) $mkdef --ordinals $args{generator}->[0] --name $args{generator}->[1] --OS windows > $target
EOF
} elsif ($args{src} !~ /\.[sS]$/) {
my $target = $args{src};
diff --git a/build.info b/build.info
index 16e587e..ceb250f 100644
--- a/build.info
+++ b/build.info
@@ -1,4 +1,6 @@
{-
+ use File::Spec::Functions;
+
our $sover = $config{shlib_version_number};
our $sover_filename = $sover;
$sover_filename =~ s|\.|_|g
@@ -28,8 +30,8 @@ IF[{- defined $target{shared_defflag} -}]
SHARED_SOURCE[libcrypto]=libcrypto.ld
SHARED_SOURCE[libssl]=libssl.ld
- GENERATE[libcrypto.ld]=util/libcrypto.num crypto
- GENERATE[libssl.ld]=util/libssl.num ssl
+ GENERATE[libcrypto.ld]=util/libcrypto.num libcrypto
+ GENERATE[libssl.ld]=util/libssl.num libssl
ENDIF
IF[{- $config{target} =~ /^(?:Cygwin|mingw|VC-)/ -}]
diff --git a/test/recipes/01-test_symbol_presence.t b/test/recipes/01-test_symbol_presence.t
index 7f2a2d7..015dee9 100644
--- a/test/recipes/01-test_symbol_presence.t
+++ b/test/recipes/01-test_symbol_presence.t
@@ -49,8 +49,9 @@ foreach my $libname (@libnames) {
my @def_lines;
indir $bldtop => sub {
my $mkdefpath = srctop_file("util", "mkdef.pl");
- @def_lines = map { s|\R$||; $_ } `$^X $mkdefpath $libname linux 2> /dev/null`;
- ok($? == 0, "running 'cd $bldtop; $^X $mkdefpath $libname linux' => $?");
+ my $libnumpath = srctop_file("util", "lib$libname.num");
+ @def_lines = map { s|\R$||; $_ } `$^X $mkdefpath --ordinals $libnumpath --name $libname --OS linux 2> /dev/null`;
+ ok($? == 0, "running 'cd $bldtop; $^X $mkdefpath --ordinals $libnumpath --name $libname --OS linux' => $?");
}, create => 0, cleanup => 0;
note "Number of lines in \@nm_lines before massaging: ", scalar @nm_lines;
diff --git a/util/libcrypto.num b/util/libcrypto.num
index bad3a38..ecece38 100644
--- a/util/libcrypto.num
+++ b/util/libcrypto.num
@@ -2529,7 +2529,7 @@ ASN1_STRING_type_new 2494 1_1_0 EXIST::FUNCTION:
TS_STATUS_INFO_free 2495 1_1_0 EXIST::FUNCTION:TS
BN_mod_mul 2496 1_1_0 EXIST::FUNCTION:
CMS_add0_recipient_key 2497 1_1_0 EXIST::FUNCTION:CMS
-BIO_f_zlib 2498 1_1_0 EXIST:ZLIB:FUNCTION:COMP
+BIO_f_zlib 2498 1_1_0 EXIST::FUNCTION:COMP,ZLIB
AES_cfb128_encrypt 2499 1_1_0 EXIST::FUNCTION:
ENGINE_set_EC 2500 1_1_0 EXIST::FUNCTION:ENGINE
d2i_ECPKParameters 2501 1_1_0 EXIST::FUNCTION:EC
diff --git a/util/mkdef.pl b/util/mkdef.pl
index 6523a05..959a13d 100755
--- a/util/mkdef.pl
+++ b/util/mkdef.pl
@@ -1,57 +1,41 @@
#! /usr/bin/env perl
-# Copyright 1995-2018 The OpenSSL Project Authors. All Rights Reserved.
+# Copyright 2018 The OpenSSL Project Authors. All Rights Reserved.
#
# Licensed under the OpenSSL license (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
-#
-# generate a .def file
-#
-# It does this by parsing the header files and looking for the
-# prototyped functions: it then prunes the output.
-#
-# Intermediary files are created, call libcrypto.num and libssl.num,
-# The format of these files is:
-#
-# routine-name nnnn vers info
-#
-# The "nnnn" and "vers" fields are the numeric id and version for the symbol
-# respectively. The "info" part is actually a colon-separated string of fields
-# with the following meaning:
-#
-# existence:platform:kind:algorithms
-#
-# - "existence" can be "EXIST" or "NOEXIST" depending on if the symbol is
-# found somewhere in the source,
-# - "platforms" is empty if it exists on all platforms, otherwise it contains
-# comma-separated list of the platform, just as they are if the symbol exists
-# for those platforms, or prepended with a "!" if not. This helps resolve
-# symbol name variants for platforms where the names are too long for the
-# compiler or linker, or if the systems is case insensitive and there is a
-# clash, or the symbol is implemented differently (see
-# EXPORT_VAR_AS_FUNCTION). This script assumes renaming of symbols is found
-# in the file crypto/symhacks.h.
-# The semantics for the platforms is that every item is checked against the
-# environment. For the negative items ("!FOO"), if any of them is false
-# (i.e. "FOO" is true) in the environment, the corresponding symbol can't be
-# used. For the positive items, if all of them are false in the environment,
-# the corresponding symbol can't be used. Any combination of positive and
-# negative items are possible, and of course leave room for some redundancy.
-# - "kind" is "FUNCTION" or "VARIABLE". The meaning of that is obvious.
-# - "algorithms" is a comma-separated list of algorithm names. This helps
-# exclude symbols that are part of an algorithm that some user wants to
-# exclude.
-#
+# Generate a linker version script suitable for the given platform
+# from a given ordinals file.
-use lib ".";
-use configdata;
-use File::Spec::Functions;
-use File::Basename;
+use strict;
+use warnings;
+
+use Getopt::Long;
use FindBin;
use lib "$FindBin::Bin/perl";
-use OpenSSL::Glob;
+
+use OpenSSL::Ordinals;
+
+use lib '.';
+use configdata;
+
+my $name = undef; # internal library/module name
+my $ordinals_file = undef; # the ordinals file to use
+my $OS = undef; # the operating system family
+my $verbose = 0;
+my $ctest = 0;
+
+GetOptions('name=s' => \$name,
+ 'ordinals=s' => \$ordinals_file,
+ 'OS=s' => \$OS,
+ 'ctest' => \$ctest,
+ 'verbose' => \$verbose)
+ or die "Error in command line arguments\n";
+
+die "Please supply arguments\n"
+ unless $name && $ordinals_file && $OS;
# When building a "variant" shared library, with a custom SONAME, also customize
# all the symbol versions. This produces a shared object that can coexist
@@ -103,1532 +87,302 @@ use OpenSSL::Glob;
# 0000000000000000 A OPENSSL_OPT_1_1_0
# 0000000000000000 A OPENSSL_OPT_1_1_0d
#
-(my $SO_VARIANT = qq{\U$target{"shlib_variant"}}) =~ s/\W/_/g;
-
-my $debug=0;
-my $trace=0;
-my $verbose=0;
-
-my $crypto_num= catfile($config{sourcedir},"util","libcrypto.num");
-my $ssl_num= catfile($config{sourcedir},"util","libssl.num");
-my $libname;
-
-my $do_update = 0;
-my $do_rewrite = 1;
-my $do_crypto = 0;
-my $do_ssl = 0;
-my $do_ctest = 0;
-my $do_ctestall = 0;
-my $do_checkexist = 0;
-
-my $VMS=0;
-my $W32=0;
-my $NT=0;
-my $UNIX=0;
-my $linux=0;
-my $aix=0;
-# Set this to make typesafe STACK definitions appear in DEF
-my $safe_stack_def = 0;
-
-my @known_platforms = ( "__FreeBSD__", "PERL5",
- "EXPORT_VAR_AS_FUNCTION", "ZLIB", "_WIN32"
- );
-my @known_ossl_platforms = ( "UNIX", "VMS", "WIN32", "WINNT", "OS2" );
-my @known_algorithms = ( # These are algorithms we know are guarded in relevant
- # header files, but aren't actually disablable.
- # Without these, this script will warn a lot.
- "RSA", "MD5",
- # @disablables comes from configdata.pm
- map { (my $x = uc $_) =~ s|-|_|g; $x; } @disablables,
- # Deprecated functions. Not really algorithmss, but
- # treated as such here for the sake of simplicity
- "DEPRECATEDIN_0_9_8",
- "DEPRECATEDIN_1_0_0",
- "DEPRECATEDIN_1_1_0",
- "DEPRECATEDIN_1_2_0",
- );
-
-# %disabled comes from configdata.pm
-my %disabled_algorithms =
- map { (my $x = uc $_) =~ s|-|_|g; $x => 1; } keys %disabled;
-
-my $apiv = sprintf "%x%02x%02x", split(/\./, $config{api});
-foreach (@known_algorithms) {
- if (/^DEPRECATEDIN_(\d+)_(\d+)_(\d+)$/) {
- my $depv = sprintf "%x%02x%02x", $1, $2, $3;
- $disabled_algorithms{$_} = 1 if $apiv ge $depv;
- }
-}
-
-my $zlib;
-
-foreach (@ARGV, split(/ /, $config{options}))
- {
- $debug=1 if $_ eq "debug";
- $trace=1 if $_ eq "trace";
- $verbose=1 if $_ eq "verbose";
- die "win16 not supported" if $_ eq "16";
- if ($_ eq "32" || $_ eq "mingw") {
- $W32=1;
- } elsif ($_ eq "NT") {
- $W32 = 1;
- $NT = 1;
- } elsif ($_ eq "linux" || $_ eq "solaris") {
- $linux=1;
- $UNIX=1;
- } elsif ($_ eq "aix") {
- $aix=1;
- $UNIX=1;
- } elsif ($_ eq "VMS") {
- $VMS=1;
- }
- if ($_ eq "zlib" || $_ eq "enable-zlib" || $_ eq "zlib-dynamic"
- || $_ eq "enable-zlib-dynamic") {
- $zlib = 1;
- }
-
- $do_crypto=1 if $_ eq "libcrypto" || $_ eq "crypto";
- $do_ssl=1 if $_ eq "libssl" || $_ eq "ssl";
-
- $do_update=1 if $_ eq "update";
- $do_rewrite=1 if $_ eq "rewrite";
- $do_ctest=1 if $_ eq "ctest";
- $do_ctestall=1 if $_ eq "ctestall";
- $do_checkexist=1 if $_ eq "exist";
- }
-$libname = $unified_info{sharednames}->{libcrypto} if $do_crypto;
-$libname = $unified_info{sharednames}->{libssl} if $do_ssl;
-
-if (!$libname) {
- if ($do_ssl) {
- $libname="LIBSSL";
- }
- if ($do_crypto) {
- $libname="LIBCRYPTO";
- }
-}
-
-# If no platform is given, assume WIN32
-if ($W32 + $VMS + $linux + $aix == 0) {
- $W32 = 1;
-}
-die "Please, only one platform at a time"
- if ($W32 + $VMS + $linux + $aix > 1);
-
-if (!$do_ssl && !$do_crypto)
- {
- print STDERR "usage: $0 ( ssl | crypto ) [ 16 | 32 | NT | OS2 | linux | VMS ]\n";
- exit(1);
- }
-
-%ssl_list=&load_numbers($ssl_num);
-$max_ssl = $max_num;
-%crypto_list=&load_numbers($crypto_num);
-$max_crypto = $max_num;
-
-my $ssl="include/openssl/ssl.h";
-$ssl.=" include/openssl/sslerr.h";
-$ssl.=" include/openssl/tls1.h";
-$ssl.=" include/openssl/srtp.h";
-
-# When scanning include/openssl, skip all SSL files and some internal ones.
-my %skipthese;
-foreach my $f ( split(/\s+/, $ssl) ) {
- $skipthese{$f} = 1;
-}
-$skipthese{'include/openssl/conf_api.h'} = 1;
-$skipthese{'include/openssl/ebcdic.h'} = 1;
-$skipthese{'include/openssl/opensslconf.h'} = 1;
-
-# We use headers found in include/openssl and include/internal only.
-# The latter is needed so libssl.so/.dll/.exe can link properly.
-my $crypto ="include/internal/dso.h";
-$crypto.=" include/internal/o_dir.h";
-$crypto.=" include/internal/o_str.h";
-$crypto.=" include/internal/err.h";
-$crypto.=" include/internal/sslconf.h";
-foreach my $f ( glob(catfile($config{sourcedir},'include/openssl/*.h')) ) {
- my $fn = "include/openssl/" . basename($f);
- $crypto .= " $fn" if !defined $skipthese{$fn};
-}
-
-my $symhacks="include/openssl/symhacks.h";
-
-my @ssl_symbols = &do_defs("LIBSSL", $ssl, $symhacks);
-my @crypto_symbols = &do_defs("LIBCRYPTO", $crypto, $symhacks);
-
-if ($do_update) {
-
-if ($do_ssl == 1) {
-
- &maybe_add_info("LIBSSL",*ssl_list, at ssl_symbols);
- if ($do_rewrite == 1) {
- open(OUT, ">$ssl_num");
- &rewrite_numbers(*OUT,"LIBSSL",*ssl_list, at ssl_symbols);
- } else {
- open(OUT, ">>$ssl_num");
- }
- &update_numbers(*OUT,"LIBSSL",*ssl_list,$max_ssl, at ssl_symbols);
- close OUT;
-}
-
-if($do_crypto == 1) {
-
- &maybe_add_info("LIBCRYPTO",*crypto_list, at crypto_symbols);
- if ($do_rewrite == 1) {
- open(OUT, ">$crypto_num");
- &rewrite_numbers(*OUT,"LIBCRYPTO",*crypto_list, at crypto_symbols);
- } else {
- open(OUT, ">>$crypto_num");
- }
- &update_numbers(*OUT,"LIBCRYPTO",*crypto_list,$max_crypto, at crypto_symbols);
- close OUT;
-}
-
-} elsif ($do_checkexist) {
- &check_existing(*ssl_list, @ssl_symbols)
- if $do_ssl == 1;
- &check_existing(*crypto_list, @crypto_symbols)
- if $do_crypto == 1;
-} elsif ($do_ctest || $do_ctestall) {
-
- print <<"EOF";
-
-/* Test file to check all DEF file symbols are present by trying
- * to link to all of them. This is *not* intended to be run!
- */
-
-int main()
-{
-EOF
- &print_test_file(*STDOUT,"LIBSSL",*ssl_list,$do_ctestall, at ssl_symbols)
- if $do_ssl == 1;
-
- &print_test_file(*STDOUT,"LIBCRYPTO",*crypto_list,$do_ctestall, at crypto_symbols)
- if $do_crypto == 1;
-
- print "}\n";
-
-} else {
-
- &print_def_file(*STDOUT,$libname,*ssl_list, at ssl_symbols)
- if $do_ssl == 1;
-
- &print_def_file(*STDOUT,$libname,*crypto_list, at crypto_symbols)
- if $do_crypto == 1;
-
-}
-
-
-sub do_defs
-{
- my($name,$files,$symhacksfile)=@_;
- my $file;
- my @ret;
- my %syms;
- my %platform; # For anything undefined, we assume ""
- my %kind; # For anything undefined, we assume "FUNCTION"
- my %algorithm; # For anything undefined, we assume ""
- my %variant;
- my %variant_cnt; # To be able to allocate "name{n}" if "name"
- # is the same name as the original.
- my $cpp;
- my %unknown_algorithms = ();
- my $parens = 0;
-
- foreach $file (split(/\s+/,$symhacksfile." ".$files))
- {
- my $fn = catfile($config{sourcedir},$file);
- print STDERR "DEBUG: starting on $fn:\n" if $debug;
- print STDERR "TRACE: start reading $fn\n" if $trace;
- open(IN,"<$fn") || die "Can't open $fn, $!,";
- my $line = "", my $def= "";
- my %tag = (
- (map { $_ => 0 } @known_platforms),
- (map { "OPENSSL_SYS_".$_ => 0 } @known_ossl_platforms),
- (map { "OPENSSL_NO_".$_ => 0 } @known_algorithms),
- (map { "OPENSSL_USE_".$_ => 0 } @known_algorithms),
- (grep /^DEPRECATED_/, @known_algorithms),
- NOPROTO => 0,
- PERL5 => 0,
- _WINDLL => 0,
- CONST_STRICT => 0,
- TRUE => 1,
- );
- my $symhacking = $file eq $symhacksfile;
- my @current_platforms = ();
- my @current_algorithms = ();
-
- # params: symbol, alias, platforms, kind
- # The reason to put this subroutine in a variable is that
- # it will otherwise create it's own, unshared, version of
- # %tag and %variant...
- my $make_variant = sub
- {
- my ($s, $a, $p, $k) = @_;
- my ($a1, $a2);
-
- print STDERR "DEBUG: make_variant: Entered with ",$s,", ",$a,", ",(defined($p)?$p:""),", ",(defined($k)?$k:""),"\n" if $debug;
- if (defined($p))
- {
- $a1 = join(",",$p,
- grep(!/^$/,
- map { $tag{$_} == 1 ? $_ : "" }
- @known_platforms));
- }
- else
- {
- $a1 = join(",",
- grep(!/^$/,
- map { $tag{$_} == 1 ? $_ : "" }
- @known_platforms));
- }
- $a2 = join(",",
- grep(!/^$/,
- map { $tag{"OPENSSL_SYS_".$_} == 1 ? $_ : "" }
- @known_ossl_platforms));
- print STDERR "DEBUG: make_variant: a1 = $a1; a2 = $a2\n" if $debug;
- if ($a1 eq "") { $a1 = $a2; }
- elsif ($a1 ne "" && $a2 ne "") { $a1 .= ",".$a2; }
- if ($a eq $s)
- {
- if (!defined($variant_cnt{$s}))
- {
- $variant_cnt{$s} = 0;
- }
- $variant_cnt{$s}++;
- $a .= "{$variant_cnt{$s}}";
- }
- my $toadd = $a.":".$a1.(defined($k)?":".$k:"");
- my $togrep = $s.'(\{[0-9]+\})?:'.$a1.(defined($k)?":".$k:"");
- if (!grep(/^$togrep$/,
- split(/;/, defined($variant{$s})?$variant{$s}:""))) {
- if (defined($variant{$s})) { $variant{$s} .= ";"; }
- $variant{$s} .= $toadd;
- }
- print STDERR "DEBUG: make_variant: Exit with variant of ",$s," = ",$variant{$s},"\n" if $debug;
- };
-
- print STDERR "DEBUG: parsing ----------\n" if $debug;
- while(<IN>) {
- s|\R$||; # Better chomp
- if($parens > 0) {
- #Inside a DEPRECATEDIN
- $stored_multiline .= $_;
- print STDERR "DEBUG: Continuing multiline DEPRECATEDIN: $stored_multiline\n" if $debug;
- $parens = count_parens($stored_multiline);
- if ($parens == 0) {
- $def .= do_deprecated($stored_multiline,
- \@current_platforms,
- \@current_algorithms);
- }
- next;
- }
- if (/\/\* Error codes for the \w+ functions\. \*\//)
- {
- undef @tag;
- last;
- }
- if ($line ne '') {
- $_ = $line . $_;
- $line = '';
- }
-
- if (/\\$/) {
- $line = $`; # keep what was before the backslash
- next;
- }
-
- if(/\/\*/) {
- if (not /\*\//) { # multi-line comment...
- $line = $_; # ... just accumulate
- next;
- } else {
- s/\/\*.*?\*\///gs;# wipe it
- }
- }
-
- if ($cpp) {
- $cpp++ if /^#\s*if/;
- $cpp-- if /^#\s*endif/;
- next;
- }
- if (/^#.*ifdef.*cplusplus/) {
- $cpp = 1;
- next;
- }
-
- s/{[^{}]*}//gs; # ignore {} blocks
- print STDERR "DEBUG: \$def=\"$def\"\n" if $debug && $def ne "";
- print STDERR "DEBUG: \$_=\"$_\"\n" if $debug;
- if (/^\#\s*if\s+OPENSSL_API_COMPAT\s*(\S)\s*(0x[0-9a-fA-F]{8})L\s*$/) {
- my $op = $1;
- my $v = hex($2);
- if ($op ne '<' && $op ne '>=') {
- die "$file unacceptable operator $op: $_\n";
- }
- my ($one, $major, $minor) =
- ( ($v >> 28) & 0xf,
- ($v >> 20) & 0xff,
- ($v >> 12) & 0xff );
- my $t = "DEPRECATEDIN_${one}_${major}_${minor}";
- push(@tag,"-");
- push(@tag,$t);
- $tag{$t}=($op eq '<' ? 1 : -1);
- print STDERR "DEBUG: $file: found tag $t = $tag{$t}\n" if $debug;
- } elsif (/^\#\s*ifndef\s+(.*)/) {
- push(@tag,"-");
- push(@tag,$1);
- $tag{$1}=-1;
- print STDERR "DEBUG: $file: found tag $1 = -1\n" if $debug;
- } elsif (/^\#\s*if\s+!defined\s*\(([^\)]+)\)/) {
- push(@tag,"-");
- if (/^\#\s*if\s+(!defined\s*\(([^\)]+)\)(\s+\&\&\s+!defined\s*\(([^\)]+)\))*)$/) {
- my $tmp_1 = $1;
- my $tmp_;
- foreach $tmp_ (split '\&\&',$tmp_1) {
- $tmp_ =~ /!defined\s*\(([^\)]+)\)/;
- print STDERR "DEBUG: $file: found tag $1 = -1\n" if $debug;
- push(@tag,$1);
- $tag{$1}=-1;
- }
- } else {
- print STDERR "Warning: $file: taking only '!defined($1)' of complicated expression: $_" if $verbose; # because it is O...
- print STDERR "DEBUG: $file: found tag $1 = -1\n" if $debug;
- push(@tag,$1);
- $tag{$1}=-1;
- }
- } elsif (/^\#\s*ifdef\s+(\S*)/) {
- push(@tag,"-");
- push(@tag,$1);
- $tag{$1}=1;
- print STDERR "DEBUG: $file: found tag $1 = 1\n" if $debug;
- } elsif (/^\#\s*if\s+defined\s*\(([^\)]+)\)/) {
- push(@tag,"-");
- if (/^\#\s*if\s+(defined\s*\(([^\)]+)\)(\s+\|\|\s+defined\s*\(([^\)]+)\))*)$/) {
- my $tmp_1 = $1;
- my $tmp_;
- foreach $tmp_ (split '\|\|',$tmp_1) {
- $tmp_ =~ /defined\s*\(([^\)]+)\)/;
- print STDERR "DEBUG: $file: found tag $1 = 1\n" if $debug;
- push(@tag,$1);
- $tag{$1}=1;
- }
- } else {
- print STDERR "Warning: $file: taking only 'defined($1)' of complicated expression: $_\n" if $verbose; # because it is O...
- print STDERR "DEBUG: $file: found tag $1 = 1\n" if $debug;
- push(@tag,$1);
- $tag{$1}=1;
- }
- } elsif (/^\#\s*error\s+(\w+) is disabled\./) {
- my $tag_i = $#tag;
- while($tag[$tag_i] ne "-") {
- if ($tag[$tag_i] eq "OPENSSL_NO_".$1) {
- $tag{$tag[$tag_i]}=2;
- print STDERR "DEBUG: $file: changed tag $1 = 2\n" if $debug;
- }
- $tag_i--;
- }
- } elsif (/^\#\s*endif/) {
- my $tag_i = $#tag;
- while($tag_i > 0 && $tag[$tag_i] ne "-") {
- my $t=$tag[$tag_i];
- print STDERR "DEBUG: \$t=\"$t\"\n" if $debug;
- if ($tag{$t}==2) {
- $tag{$t}=-1;
- } else {
- $tag{$t}=0;
- }
- print STDERR "DEBUG: $file: changed tag ",$t," = ",$tag{$t},"\n" if $debug;
- pop(@tag);
- if ($t =~ /^OPENSSL_NO_([A-Z0-9_]+)$/) {
- $t=$1;
- } elsif($t =~ /^OPENSSL_USE_([A-Z0-9_]+)$/) {
- $t=$1;
- } else {
- $t="";
- }
- if ($t ne ""
- && !grep(/^$t$/, @known_algorithms)) {
- $unknown_algorithms{$t} = 1;
- #print STDERR "DEBUG: Added as unknown algorithm: $t\n" if $debug;
- }
- $tag_i--;
- }
- pop(@tag);
- } elsif (/^\#\s*else/) {
- my $tag_i = $#tag;
- die "$file unmatched else\n" if $tag_i < 0;
- while($tag[$tag_i] ne "-") {
- my $t=$tag[$tag_i];
- $tag{$t}= -$tag{$t};
- print STDERR "DEBUG: $file: changed tag ",$t," = ",$tag{$t},"\n" if $debug;
- $tag_i--;
- }
- } elsif (/^\#\s*if\s+1/) {
- push(@tag,"-");
- # Dummy tag
- push(@tag,"TRUE");
- $tag{"TRUE"}=1;
- print STDERR "DEBUG: $file: found 1\n" if $debug;
- } elsif (/^\#\s*if\s+0/) {
- push(@tag,"-");
- # Dummy tag
- push(@tag,"TRUE");
- $tag{"TRUE"}=-1;
- print STDERR "DEBUG: $file: found 0\n" if $debug;
- } elsif (/^\#\s*if\s+/) {
- #Some other unrecognized "if" style
- push(@tag,"-");
- print STDERR "Warning: $file: ignoring unrecognized expression: $_\n" if $verbose; # because it is O...
- } elsif (/^\#\s*define\s+(\w+)\s+(\w+)/
- && $symhacking && $tag{'TRUE'} != -1) {
- # This is for aliasing. When we find an alias,
- # we have to invert
- &$make_variant($1,$2);
- print STDERR "DEBUG: $file: defined $1 = $2\n" if $debug;
- }
- if (/^\#/) {
- @current_platforms =
- grep(!/^$/,
- map { $tag{$_} == 1 ? $_ :
- $tag{$_} == -1 ? "!".$_ : "" }
- @known_platforms);
- push @current_platforms
- , grep(!/^$/,
- map { $tag{"OPENSSL_SYS_".$_} == 1 ? $_ :
- $tag{"OPENSSL_SYS_".$_} == -1 ? "!".$_ : "" }
- @known_ossl_platforms);
- @current_algorithms = ();
- @current_algorithms =
- grep(!/^$/,
- map { $tag{"OPENSSL_NO_".$_} == -1 ? $_ : "" }
- @known_algorithms);
- push @current_algorithms
- , grep(!/^$/,
- map { $tag{"OPENSSL_USE_".$_} == 1 ? $_ : "" }
- @known_algorithms);
- push @current_algorithms,
- grep { /^DEPRECATEDIN_/ && $tag{$_} == 1 }
- @known_algorithms;
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- next;
- }
- if ($tag{'TRUE'} != -1) {
- if (/^\s*DEFINE_STACK_OF\s*\(\s*(\w*)\s*\)/
- || /^\s*DEFINE_STACK_OF_CONST\s*\(\s*(\w*)\s*\)/) {
- next;
- } elsif (/^\s*DECLARE_ASN1_ENCODE_FUNCTIONS\s*\(\s*(\w*)\s*,\s*(\w*)\s*,\s*(\w*)\s*\)/) {
- $def .= "int d2i_$3(void);";
- $def .= "int i2d_$3(void);";
- # Variant for platforms that do not
- # have to access global variables
- # in shared libraries through functions
- $def .=
- "#INFO:"
- .join(',',"!EXPORT_VAR_AS_FUNCTION", at current_platforms).":"
- .join(',', at current_algorithms).";";
- $def .= "OPENSSL_EXTERN int $2_it;";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Variant for platforms that have to
- # access global variables in shared
- # libraries through functions
- &$make_variant("$2_it","$2_it",
- "EXPORT_VAR_AS_FUNCTION",
- "FUNCTION");
- next;
- } elsif (/^\s*DECLARE_ASN1_FUNCTIONS_fname\s*\(\s*(\w*)\s*,\s*(\w*)\s*,\s*(\w*)\s*\)/) {
- $def .= "int d2i_$3(void);";
- $def .= "int i2d_$3(void);";
- $def .= "int $3_free(void);";
- $def .= "int $3_new(void);";
- # Variant for platforms that do not
- # have to access global variables
- # in shared libraries through functions
- $def .=
- "#INFO:"
- .join(',',"!EXPORT_VAR_AS_FUNCTION", at current_platforms).":"
- .join(',', at current_algorithms).";";
- $def .= "OPENSSL_EXTERN int $2_it;";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Variant for platforms that have to
- # access global variables in shared
- # libraries through functions
- &$make_variant("$2_it","$2_it",
- "EXPORT_VAR_AS_FUNCTION",
- "FUNCTION");
- next;
- } elsif (/^\s*DECLARE_ASN1_FUNCTIONS\s*\(\s*(\w*)\s*\)/ ||
- /^\s*DECLARE_ASN1_FUNCTIONS_const\s*\(\s*(\w*)\s*\)/) {
- $def .= "int d2i_$1(void);";
- $def .= "int i2d_$1(void);";
- $def .= "int $1_free(void);";
- $def .= "int $1_new(void);";
- # Variant for platforms that do not
- # have to access global variables
- # in shared libraries through functions
- $def .=
- "#INFO:"
- .join(',',"!EXPORT_VAR_AS_FUNCTION", at current_platforms).":"
- .join(',', at current_algorithms).";";
- $def .= "OPENSSL_EXTERN int $1_it;";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Variant for platforms that have to
- # access global variables in shared
- # libraries through functions
- &$make_variant("$1_it","$1_it",
- "EXPORT_VAR_AS_FUNCTION",
- "FUNCTION");
- next;
- } elsif (/^\s*DECLARE_ASN1_ENCODE_FUNCTIONS_const\s*\(\s*(\w*)\s*,\s*(\w*)\s*\)/) {
- $def .= "int d2i_$2(void);";
- $def .= "int i2d_$2(void);";
- # Variant for platforms that do not
- # have to access global variables
- # in shared libraries through functions
- $def .=
- "#INFO:"
- .join(',',"!EXPORT_VAR_AS_FUNCTION", at current_platforms).":"
- .join(',', at current_algorithms).";";
- $def .= "OPENSSL_EXTERN int $2_it;";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Variant for platforms that have to
- # access global variables in shared
- # libraries through functions
- &$make_variant("$2_it","$2_it",
- "EXPORT_VAR_AS_FUNCTION",
- "FUNCTION");
- next;
- } elsif (/^\s*DECLARE_ASN1_ALLOC_FUNCTIONS\s*\(\s*(\w*)\s*\)/) {
- $def .= "int $1_free(void);";
- $def .= "int $1_new(void);";
- next;
- } elsif (/^\s*DECLARE_ASN1_FUNCTIONS_name\s*\(\s*(\w*)\s*,\s*(\w*)\s*\)/) {
- $def .= "int d2i_$2(void);";
- $def .= "int i2d_$2(void);";
- $def .= "int $2_free(void);";
- $def .= "int $2_new(void);";
- # Variant for platforms that do not
- # have to access global variables
- # in shared libraries through functions
- $def .=
- "#INFO:"
- .join(',',"!EXPORT_VAR_AS_FUNCTION", at current_platforms).":"
- .join(',', at current_algorithms).";";
- $def .= "OPENSSL_EXTERN int $2_it;";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Variant for platforms that have to
- # access global variables in shared
- # libraries through functions
- &$make_variant("$2_it","$2_it",
- "EXPORT_VAR_AS_FUNCTION",
- "FUNCTION");
- next;
- } elsif (/^\s*DECLARE_ASN1_ITEM\s*\(\s*(\w*)\s*\)/) {
- # Variant for platforms that do not
- # have to access global variables
- # in shared libraries through functions
- $def .=
- "#INFO:"
- .join(',',"!EXPORT_VAR_AS_FUNCTION", at current_platforms).":"
- .join(',', at current_algorithms).";";
- $def .= "OPENSSL_EXTERN int $1_it;";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Variant for platforms that have to
- # access global variables in shared
- # libraries through functions
- &$make_variant("$1_it","$1_it",
- "EXPORT_VAR_AS_FUNCTION",
- "FUNCTION");
- next;
- } elsif (/^\s*DECLARE_ASN1_NDEF_FUNCTION\s*\(\s*(\w*)\s*\)/) {
- $def .= "int i2d_$1_NDEF(void);";
- } elsif (/^\s*DECLARE_ASN1_SET_OF\s*\(\s*(\w*)\s*\)/) {
- next;
- } elsif (/^\s*DECLARE_ASN1_PRINT_FUNCTION\s*\(\s*(\w*)\s*\)/) {
- $def .= "int $1_print_ctx(void);";
- next;
- } elsif (/^\s*DECLARE_ASN1_PRINT_FUNCTION_name\s*\(\s*(\w*)\s*,\s*(\w*)\s*\)/) {
- $def .= "int $2_print_ctx(void);";
- next;
- } elsif (/^\s*DECLARE_PKCS12_STACK_OF\s*\(\s*(\w*)\s*\)/) {
- next;
- } elsif (/^DECLARE_PEM_rw\s*\(\s*(\w*)\s*,/ ||
- /^DECLARE_PEM_rw_cb\s*\(\s*(\w*)\s*,/ ||
- /^DECLARE_PEM_rw_const\s*\(\s*(\w*)\s*,/ ) {
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',',"STDIO", at current_algorithms).";";
- $def .= "int PEM_read_$1(void);";
- $def .= "int PEM_write_$1(void);";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Things that are everywhere
- $def .= "int PEM_read_bio_$1(void);";
- $def .= "int PEM_write_bio_$1(void);";
- next;
- } elsif (/^DECLARE_PEM_write\s*\(\s*(\w*)\s*,/ ||
- /^DECLARE_PEM_write_const\s*\(\s*(\w*)\s*,/ ||
- /^DECLARE_PEM_write_cb\s*\(\s*(\w*)\s*,/ ) {
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',',"STDIO", at current_algorithms).";";
- $def .= "int PEM_write_$1(void);";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Things that are everywhere
- $def .= "int PEM_write_bio_$1(void);";
- next;
- } elsif (/^DECLARE_PEM_read\s*\(\s*(\w*)\s*,/ ||
- /^DECLARE_PEM_read_cb\s*\(\s*(\w*)\s*,/ ) {
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',',"STDIO", at current_algorithms).";";
- $def .= "int PEM_read_$1(void);";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',',"STDIO", at current_algorithms).";";
- # Things that are everywhere
- $def .= "int PEM_read_bio_$1(void);";
- next;
- } elsif (/^OPENSSL_DECLARE_GLOBAL\s*\(\s*(\w*)\s*,\s*(\w*)\s*\)/) {
- # Variant for platforms that do not
- # have to access global variables
- # in shared libraries through functions
- $def .=
- "#INFO:"
- .join(',',"!EXPORT_VAR_AS_FUNCTION", at current_platforms).":"
- .join(',', at current_algorithms).";";
- $def .= "OPENSSL_EXTERN int _shadow_$2;";
- $def .=
- "#INFO:"
- .join(',', at current_platforms).":"
- .join(',', at current_algorithms).";";
- # Variant for platforms that have to
- # access global variables in shared
- # libraries through functions
- &$make_variant("_shadow_$2","_shadow_$2",
- "EXPORT_VAR_AS_FUNCTION",
- "FUNCTION");
- } elsif (/^\s*DEPRECATEDIN/) {
- $parens = count_parens($_);
- if ($parens == 0) {
- $def .= do_deprecated($_,
- \@current_platforms,
- \@current_algorithms);
- } else {
- $stored_multiline = $_;
- print STDERR "DEBUG: Found multiline DEPRECATEDIN starting with: $stored_multiline\n" if $debug;
- next;
- }
- } elsif ($tag{'CONST_STRICT'} != 1) {
- if (/\{|\/\*|\([^\)]*$/) {
- $line = $_;
- } else {
- $def .= $_;
- }
- }
- }
- }
- close(IN);
- die "$file: Unmatched tags\n" if $#tag >= 0;
-
- my $algs;
- my $plays;
-
- print STDERR "DEBUG: postprocessing ----------\n" if $debug;
- foreach (split /;/, $def) {
- my $s; my $k = "FUNCTION"; my $p; my $a;
- s/^[\n\s]*//g;
- s/[\n\s]*$//g;
- next if(/\#undef/);
- next if(/typedef\W/);
- next if(/\#define/);
-
- print STDERR "TRACE: processing $_\n" if $trace && !/^\#INFO:/;
- # Reduce argument lists to empty ()
- # fold round brackets recursively: (t(*v)(t),t) -> (t{}{},t) -> {}
- my $nsubst = 1; # prevent infinite loop, e.g., on int fn()
- while($nsubst && /\(.*\)/s) {
- $nsubst = s/\([^\(\)]+\)/\{\}/gs;
- $nsubst+= s/\(\s*\*\s*(\w+)\s*\{\}\s*\)/$1/gs; #(*f{}) -> f
- }
- # pretend as we didn't use curly braces: {} -> ()
- s/\{\}/\(\)/gs;
-
- s/STACK_OF\(\)/void/gs;
- s/LHASH_OF\(\)/void/gs;
-
- print STDERR "DEBUG: \$_ = \"$_\"\n" if $debug;
- if (/^\#INFO:([^:]*):(.*)$/) {
- $plats = $1;
- $algs = $2;
- print STDERR "DEBUG: found info on platforms ($plats) and algorithms ($algs)\n" if $debug;
- next;
- } elsif (/^\s*OPENSSL_EXTERN\s.*?(\w+(\{[0-9]+\})?)(\[[0-9]*\])*\s*$/) {
- $s = $1;
- $k = "VARIABLE";
- print STDERR "DEBUG: found external variable $s\n" if $debug;
- } elsif (/TYPEDEF_\w+_OF/s) {
- next;
- } elsif (/(\w+)\s*\(\).*/s) { # first token prior [first] () is
- $s = $1; # a function name!
- print STDERR "DEBUG: found function $s\n" if $debug;
- } elsif (/\(/ and not (/=/)) {
- print STDERR "File $file: cannot parse: $_;\n";
- next;
- } else {
- next;
- }
-
- $syms{$s} = 1;
- $kind{$s} = $k;
-
- $p = $plats;
- $a = $algs;
-
- $platform{$s} =
- &reduce_platforms((defined($platform{$s})?$platform{$s}.',':"").$p);
- $algorithm{$s} .= ','.$a;
-
- if (defined($variant{$s})) {
- foreach $v (split /;/,$variant{$s}) {
- (my $r, my $p, my $k) = split(/:/,$v);
- my $ip = join ',',map({ /^!(.*)$/ ? $1 : "!".$_ } split /,/, $p);
- $syms{$r} = 1;
- if (!defined($k)) { $k = $kind{$s}; }
- $kind{$r} = $k."(".$s.")";
- $algorithm{$r} = $algorithm{$s};
- $platform{$r} = &reduce_platforms($platform{$s}.",".$p.",".$p);
- $platform{$s} = &reduce_platforms($platform{$s}.','.$ip.','.$ip);
- print STDERR "DEBUG: \$variant{\"$s\"} = ",$v,"; \$r = $r; \$p = ",$platform{$r},"; \$a = ",$algorithm{$r},"; \$kind = ",$kind{$r},"\n" if $debug;
- }
- }
- print STDERR "DEBUG: \$s = $s; \$p = ",$platform{$s},"; \$a = ",$algorithm{$s},"; \$kind = ",$kind{$s},"\n" if $debug;
- }
- }
-
- # Info we know about
-
- push @ret, map { $_."\\".&info_string($_,"EXIST",
- $platform{$_},
- $kind{$_},
- $algorithm{$_}) } keys %syms;
+(my $SO_VARIANT = uc($target{"shlib_variant"} // '')) =~ s/\W/_/g;
+
+my $apiv = undef;
+$apiv = sprintf "%x%02x%02x", split(/\./, $config{api})
+ if $config{api};
+
+my $libname = $unified_info{sharednames}->{$name} // $name;
+
+my %OS_data = (
+ solaris => { writer => \&writer_linux,
+ sort => sorter_linux(),
+ platforms => { UNIX => 1,
+ EXPORT_VAR_AS_FUNCTION => 0 } },
+ linux => 'solaris', # alias
+ aix => { writer => \&writer_aix,
+ sort => sorter_unix(),
+ platforms => { UNIX => 1,
+ EXPORT_VAR_AS_FUNCTION => 0 } },
+ VMS => { writer => \&writer_VMS,
+ sort => OpenSSL::Ordinals::by_number(),
+ platforms => { VMS => 1,
+ EXPORT_VAR_AS_FUNCTION => 0 } },
+ vms => 'VMS', # alias
+ WINDOWS => { writer => \&writer_windows,
+ sort => OpenSSL::Ordinals::by_name(),
+ platforms => { WIN32 => 1,
+ _WIN32 => 1,
+ EXPORT_VAR_AS_FUNCTION => 1 } },
+ windows => 'WINDOWS', # alias
+ WIN32 => 'WINDOWS', # alias
+ win32 => 'WIN32', # alias
+ 32 => 'WIN32', # alias
+ NT => 'WIN32', # alias
+ nt => 'WIN32', # alias
+ mingw => 'WINDOWS', # alias
+ );
+
+do {
+ die "Unknown operating system family $OS\n"
+ unless exists $OS_data{$OS};
+ $OS = $OS_data{$OS};
+} while(ref($OS) eq '');
+
+my %disabled_uc = map { my $x = uc $_; $x =~ s|-|_|g; $x => 1 } keys %disabled;
+
+my %ordinal_opts = ();
+$ordinal_opts{sort} = $OS->{sort} if $OS->{sort};
+$ordinal_opts{filter} =
+ sub {
+ my $item = shift;
+ return
+ $item->exists()
+ && platform_filter($item)
+ && feature_filter($item);
+ };
+my $ordinals = OpenSSL::Ordinals->new(from => $ordinals_file);
+
+my $writer = $OS->{writer};
+$writer = \&writer_ctest if $ctest;
+
+$writer->($ordinals->items(%ordinal_opts));
+
+exit 0;
+
+sub platform_filter {
+ my $item = shift;
+ my %platforms = ( $item->platforms() );
+
+ # True if no platforms are defined
+ return 1 if scalar keys %platforms == 0;
+
+ # For any item platform tag, return the equivalence with the
+ # current platform settings if it exists there, return 0 otherwise
+ # if the item platform tag is true
+ for (keys %platforms) {
+ if (exists $OS->{platforms}->{$_}) {
+ return $platforms{$_} == $OS->{platforms}->{$_};
+ }
+ if ($platforms{$_}) {
+ return 0;
+ }
+ }
- if (keys %unknown_algorithms) {
- print STDERR "WARNING: mkdef.pl doesn't know the following algorithms:\n";
- print STDERR "\t",join("\n\t",keys %unknown_algorithms),"\n";
- }
- return(@ret);
+ # Found no match? Then it's a go
+ return 1;
}
-# Param: string of comma-separated platform-specs.
-sub reduce_platforms
-{
- my ($platforms) = @_;
- my $pl = defined($platforms) ? $platforms : "";
- my %p = map { $_ => 0 } split /,/, $pl;
- my $ret;
-
- print STDERR "DEBUG: Entered reduce_platforms with \"$platforms\"\n"
- if $debug;
- # We do this, because if there's code like the following, it really
- # means the function exists in all cases and should therefore be
- # everywhere. By increasing and decreasing, we may attain 0:
- #
- # ifndef WIN16
- # int foo();
- # else
- # int _fat foo();
- # endif
- foreach $platform (split /,/, $pl) {
- if ($platform =~ /^!(.*)$/) {
- $p{$1}--;
- } else {
- $p{$platform}++;
- }
- }
- foreach $platform (keys %p) {
- if ($p{$platform} == 0) { delete $p{$platform}; }
- }
+sub feature_filter {
+ my $item = shift;
+ my @features = ( $item->features() );
- delete $p{""};
+ # True if no features are defined
+ return 1 if scalar @features == 0;
- $ret = join(',',sort(map { $p{$_} < 0 ? "!".$_ : $_ } keys %p));
- print STDERR "DEBUG: Exiting reduce_platforms with \"$ret\"\n"
- if $debug;
- return $ret;
-}
-
-sub info_string
-{
- (my $symbol, my $exist, my $platforms, my $kind, my $algorithms) = @_;
+ my $verdict = ! grep { $disabled_uc{$_} } @features;
- my %a = defined($algorithms) ?
- map { $_ => 1 } split /,/, $algorithms : ();
- my $k = defined($kind) ? $kind : "FUNCTION";
- my $ret;
- my $p = &reduce_platforms($platforms);
-
- delete $a{""};
+ if ($apiv) {
+ foreach (@features) {
+ next unless /^DEPRECATEDIN_(\d+)_(\d+)_(\d+)$/;
+ my $symdep = sprintf "%x%02x%02x", $1, $2, $3;
+ $verdict = 0 if $apiv ge $symdep;
+ }
+ }
- $ret = $exist;
- $ret .= ":".$p;
- $ret .= ":".$k;
- $ret .= ":".join(',',sort keys %a);
- return $ret;
+ return $verdict;
}
-sub maybe_add_info
-{
- (my $name, *nums, my @symbols) = @_;
- my $sym;
- my $new_info = 0;
- my %syms=();
+sub sorter_unix {
+ my $by_name = OpenSSL::Ordinals::by_name();
+ my %weight = (
+ 'FUNCTION' => 1,
+ 'VARIABLE' => 2
+ );
- foreach $sym (@symbols) {
- (my $s, my $i) = split /\\/, $sym;
- if (defined($nums{$s})) {
- $i =~ s/^(.*?:.*?:\w+)(\(\w+\))?/$1/;
- (my $n, my $vers, my $dummy) = split /\\/, $nums{$s};
- if (!defined($dummy) || $i ne $dummy) {
- $nums{$s} = $n."\\".$vers."\\".$i;
- $new_info++;
- print STDERR "DEBUG: maybe_add_info for $s: \"$dummy\" => \"$i\"\n" if $debug;
- }
- }
- $syms{$s} = 1;
- }
+ return sub {
+ my $item1 = shift;
+ my $item2 = shift;
- my @s=sort { &parse_number($nums{$a},"n") <=> &parse_number($nums{$b},"n") } keys %nums;
- foreach $sym (@s) {
- (my $n, my $vers, my $i) = split /\\/, $nums{$sym};
- if (!defined($syms{$sym}) && $i !~ /^NOEXIST:/) {
- $new_info++;
- print STDERR "DEBUG: maybe_add_info for $sym: -> undefined\n" if $debug;
- }
- }
- if ($new_info) {
- print STDERR "$name: $new_info old symbols have updated info\n";
- if (!$do_rewrite) {
- print STDERR "You should do a rewrite to fix this.\n";
- }
- } else {
- }
+ my $verdict = $weight{$item1->type()} <=> $weight{$item2->type()};
+ if ($verdict == 0) {
+ $verdict = $by_name->($item1, $item2);
+ }
+ return $verdict;
+ };
}
-# Param: string of comma-separated keywords, each possibly prefixed with a "!"
-sub is_valid
-{
- my ($keywords_txt,$platforms) = @_;
- my (@keywords) = split /,/,$keywords_txt;
- my ($falsesum, $truesum) = (0, 1);
-
- # Param: one keyword
- sub recognise
- {
- my ($keyword,$platforms) = @_;
-
- if ($platforms) {
- # platforms
- if ($keyword eq "UNIX" && $UNIX) { return 1; }
- if ($keyword eq "VMS" && $VMS) { return 1; }
- if ($keyword eq "WIN32" && $W32) { return 1; }
- if ($keyword eq "_WIN32" && $W32) { return 1; }
- if ($keyword eq "WINNT" && $NT) { return 1; }
- # Special platforms:
- # EXPORT_VAR_AS_FUNCTION means that global variables
- # will be represented as functions.
- if ($keyword eq "EXPORT_VAR_AS_FUNCTION" && $W32) {
- return 1;
- }
- if ($keyword eq "ZLIB" && $zlib) { return 1; }
- return 0;
- } else {
- # algorithms
- if ($disabled_algorithms{$keyword}) { return 0;}
+sub sorter_linux {
+ my $by_version = OpenSSL::Ordinals::by_version();
+ my $by_unix = sorter_unix();
- # Nothing recognise as true
- return 1;
- }
- }
+ return sub {
+ my $item1 = shift;
+ my $item2 = shift;
- foreach $k (@keywords) {
- if ($k =~ /^!(.*)$/) {
- $falsesum += &recognise($1,$platforms);
- } else {
- $truesum *= &recognise($k,$platforms);
- }
- }
- print STDERR "DEBUG: [",$#keywords,",",$#keywords < 0,"] is_valid($keywords_txt) => (\!$falsesum) && $truesum = ",(!$falsesum) && $truesum,"\n" if $debug;
- return (!$falsesum) && $truesum;
+ my $verdict = $by_version->($item1, $item2);
+ if ($verdict == 0) {
+ $verdict = $by_unix->($item1, $item2);
+ }
+ return $verdict;
+ };
}
-sub print_test_file
-{
- (*OUT,my $name,*nums,my $testall,my @symbols)=@_;
- my $n = 1; my @e; my @r;
- my $sym; my $prev = ""; my $prefSSLeay;
-
- (@e)=grep(/^SSLeay(\{[0-9]+\})?\\.*?:.*?:.*/, at symbols);
- (@r)=grep(/^\w+(\{[0-9]+\})?\\.*?:.*?:.*/ && !/^SSLeay(\{[0-9]+\})?\\.*?:.*?:.*/, at symbols);
- @symbols=((sort @e),(sort @r));
-
- foreach $sym (@symbols) {
- (my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
- my $v = 0;
- $v = 1 if $i=~ /^.*?:.*?:VARIABLE/;
- my $p = ($i =~ /^[^:]*:([^:]*):/,$1);
- my $a = ($i =~ /^[^:]*:[^:]*:[^:]*:([^:]*)/,$1);
- if (!defined($nums{$s})) {
- print STDERR "Warning: $s does not have a number assigned\n"
- if(!$do_update);
- } elsif (is_valid($p,1) && is_valid($a,0)) {
- my $s2 = ($s =~ /^(.*?)(\{[0-9]+\})?$/, $1);
- if ($prev eq $s2) {
- print OUT "\t/* The following has already appeared previously */\n";
- print STDERR "Warning: Symbol '",$s2,"' redefined. old=",($nums{$prev} =~ /^(.*?)\\/,$1),", new=",($nums{$s2} =~ /^(.*?)\\/,$1),"\n";
- }
- $prev = $s2; # To warn about duplicates...
+sub writer_linux {
+ my $thisversion = '';
+ my $prevversion = '';
+
+ for (@_) {
+ if ($thisversion && $_->version() ne $thisversion) {
+ print <<"_____";
+}$prevversion;
+_____
+ $prevversion = " OPENSSL${SO_VARIANT}_$thisversion";
+ $thisversion = ''; # Trigger start of next section
+ }
+ unless ($thisversion) {
+ $thisversion = $_->version();
+ print <<"_____";
+OPENSSL${SO_VARIANT}_$thisversion {
+ global:
+_____
+ }
+ print ' ', $_->name(), ";\n";
+ }
- (my $nn, my $vers, my $ni) = split /\\/, $nums{$s2};
- if ($v) {
- print OUT "\textern int $s2; /* type unknown */ /* $nn $ni */\n";
- } else {
- print OUT "\textern int $s2(); /* type unknown */ /* $nn $ni */\n";
- }
- }
- }
+ print <<"_____";
+ local: *;
+}$prevversion;
+_____
}
-sub get_version
-{
- return $config{version};
+sub writer_aix {
+ for (@_) {
+ print $_->name(),"\n";
+ }
}
-sub print_def_file
-{
- (*OUT,my $name,*nums,my @symbols)=@_;
- my $n = 1; my @e; my @r; my @v; my $prev="";
- my $liboptions="";
- my $libname = $name;
- my $http_vendor = 'www.openssl.org/';
- my $version = get_version();
- my $what = "OpenSSL: implementation of Secure Socket Layer";
- my $description = "$what $version, $name - http://$http_vendor";
- my $prevsymversion = "", $prevprevsymversion = "";
- # For VMS
- my $prevnum = 0;
- my $symvtextcount = 0;
-
- if ($W32)
- {
- print OUT <<"EOF";
+sub writer_windows {
+ print <<"_____";
;
-; Definition file for the DLL version of the $name library from OpenSSL
+; Definition file for the DLL version of the $libname library from OpenSSL
;
-LIBRARY $libname $liboptions
+LIBRARY $libname
-EOF
-
- print "EXPORTS\n";
- }
- elsif ($VMS)
- {
- print OUT <<"EOF";
-IDENTIFICATION=$version
-CASE_SENSITIVE=YES
-SYMBOL_VECTOR=(-
-EOF
- $symvtextcount = 16; # length of "SYMBOL_VECTOR=(-"
- }
+EXPORTS
+_____
+ for (@_) {
+ print " ",$_->name(),"\n";
+ }
+}
- (@r)=grep(/^\w+(\{[0-9]+\})?\\.*?:.*?:FUNCTION/, at symbols);
- (@v)=grep(/^\w+(\{[0-9]+\})?\\.*?:.*?:VARIABLE/, at symbols);
- if ($VMS) {
- # VMS needs to have the symbols on slot number order
- @symbols=(map { $_->[1] }
- sort { $a->[0] <=> $b->[0] }
- map { (my $s, my $i) = $_ =~ /^(.*?)\\(.*)$/;
- die "Error: $s doesn't have a number assigned\n"
- if !defined($nums{$s});
- (my $n, my @rest) = split /\\/, $nums{$s};
- [ $n, $_ ] } (@e, @r, @v));
+sub writer_VMS {
+ my @slot_collection = ();
+ my $write_vector_slot_pair =
+ sub {
+ my $slot1 = shift;
+ my $slot2 = shift;
+ my $slotpair_text = " $slot1, -\n $slot2, -\n"
+ };
+
+ my $last_num = 0;
+ foreach (@_) {
+ while (++$last_num < $_->number()) {
+ push @slot_collection, [ 'SPARE', 'SPARE' ];
+ }
+ my $type = {
+ FUNCTION => 'PROCEDURE',
+ VARIABLE => 'DATA'
+ } -> {$_->type()};
+ my $s = $_->name();
+ my $s_uc = uc($s);
+ if ($s_uc eq $s) {
+ push @slot_collection, [ "$s=$type", 'SPARE' ];
} else {
- @symbols=((sort @e),(sort @r), (sort @v));
+ push @slot_collection, [ "$s_uc/$s=$type", "$s=$type" ];
}
+ }
- my ($baseversion, $currversion) = get_openssl_version();
- my $thisversion;
- do {
- if (!defined($thisversion)) {
- $thisversion = $baseversion;
- } else {
- $thisversion = get_next_version($thisversion);
- }
- foreach $sym (@symbols) {
- (my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
- my $v = 0;
- $v = 1 if $i =~ /^.*?:.*?:VARIABLE/;
- if (!defined($nums{$s})) {
- die "Error: $s does not have a number assigned\n"
- if(!$do_update);
- } else {
- (my $n, my $symversion, my $dummy) = split /\\/, $nums{$s};
- my %pf = ();
- my $p = ($i =~ /^[^:]*:([^:]*):/,$1);
- my $a = ($i =~ /^[^:]*:[^:]*:[^:]*:([^:]*)/,$1);
- if (is_valid($p,1) && is_valid($a,0)) {
- my $s2 = ($s =~ /^(.*?)(\{[0-9]+\})?$/, $1);
- if ($prev eq $s2) {
- print STDERR "Warning: Symbol '",$s2,
- "' redefined. old=",($nums{$prev} =~ /^(.*?)\\/,$1),
- ", new=",($nums{$s2} =~ /^(.*?)\\/,$1),"\n";
- }
- $prev = $s2; # To warn about duplicates...
- if($linux) {
- next if $symversion ne $thisversion;
- if ($symversion ne $prevsymversion) {
- if ($prevsymversion ne "") {
- if ($prevprevsymversion ne "") {
- print OUT "} OPENSSL${SO_VARIANT}_"
- ."$prevprevsymversion;\n\n";
- } else {
- print OUT "};\n\n";
- }
- }
- print OUT "OPENSSL${SO_VARIANT}_$symversion {\n global:\n";
- $prevprevsymversion = $prevsymversion;
- $prevsymversion = $symversion;
- }
- print OUT " $s2;\n";
- } elsif ($aix) {
- print OUT "$s2\n";
- } elsif ($VMS) {
- while(++$prevnum < $n) {
- my $symline=" ,SPARE -\n ,SPARE -\n";
- if ($symvtextcount + length($symline) - 2 > 1024) {
- print OUT ")\nSYMBOL_VECTOR=(-\n";
- $symvtextcount = 16; # length of "SYMBOL_VECTOR=(-"
- }
- if ($symvtextcount == 16) {
- # Take away first comma
- $symline =~ s/,//;
- }
- print OUT $symline;
- $symvtextcount += length($symline) - 2;
- }
- (my $s_uc = $s) =~ tr/a-z/A-Z/;
- my $symtype=
- $v ? "DATA" : "PROCEDURE";
- my $symline=
- ($s_uc ne $s
- ? " ,$s_uc/$s=$symtype -\n ,$s=$symtype -\n"
- : " ,$s=$symtype -\n ,SPARE -\n");
- if ($symvtextcount + length($symline) - 2 > 1024) {
- print OUT ")\nSYMBOL_VECTOR=(-\n";
- $symvtextcount = 16; # length of "SYMBOL_VECTOR=(-"
- }
- if ($symvtextcount == 16) {
- # Take away first comma
- $symline =~ s/,//;
- }
- print OUT $symline;
- $symvtextcount += length($symline) - 2;
- } elsif($v) {
- printf OUT " %s%-39s DATA\n",
- ($W32)?"":"_",$s2;
- } else {
- printf OUT " %s%s\n",
- ($W32)?"":"_",$s2;
- }
- }
- }
- }
- } while ($linux && $thisversion ne $currversion);
- if ($linux) {
- if ($prevprevsymversion ne "") {
- print OUT " local: *;\n} OPENSSL${SO_VARIANT}_$prevprevsymversion;\n\n";
- } else {
- print OUT " local: *;\n};\n\n";
- }
- } elsif ($VMS) {
- print OUT ")\n";
- (my $libvmaj, my $libvmin, my $libvedit) =
- $currversion =~ /^(\d+)_(\d+)_(\d+)[a-z]{0,2}$/;
- # The reason to multiply the edit number with 100 is to make space
- # for the possibility that we want to encode the patch letters
- print OUT "GSMATCH=LEQUAL,",($libvmaj * 100 + $libvmin),",",($libvedit * 100),"\n";
+ print <<"_____";
+IDENTIFICATION=$config{version}
+CASE_SENSITIVE=YES
+SYMBOL_VECTOR=(-
+_____
+ # It's uncertain how long aggregated lines the linker can handle,
+ # but it has been observed that at least 1024 characters is ok.
+ # Either way, this means that we need to keep track of the total
+ # line length of each "SYMBOL_VECTOR" statement. Fortunately, we
+ # can have more than one of those...
+ my $symvtextcount = 16; # The length of "SYMBOL_VECTOR=("
+ while (@slot_collection) {
+ my $pair = shift @slot_collection;
+ my $pairtextlength =
+ 2 # one space indentation and comma
+ + length($pair->[0])
+ + 1 # postdent
+ + 3 # two space indentation and comma
+ + length($pair->[1])
+ + 1 # postdent
+ ;
+ my $firstcomma = ',';
+
+ if ($symvtextcount + $pairtextlength > 1024) {
+ print <<"_____";
+)
+SYMBOL_VECTOR=(-
+_____
+ $symvtextcount = 16; # The length of "SYMBOL_VECTOR=("
}
- printf OUT "\n";
-}
-
-sub load_numbers
-{
- my($name)=@_;
- my(@a,%ret);
- my $prevversion;
-
- $max_num = 0;
- $num_noinfo = 0;
- $prev = "";
- $prev_cnt = 0;
-
- my ($baseversion, $currversion) = get_openssl_version();
-
- open(IN,"<$name") || die "unable to open $name:$!\n";
- while (<IN>) {
- s|\R$||; # Better chomp
- s/#.*$//;
- next if /^\s*$/;
- @a=split;
- if (defined $ret{$a[0]}) {
- # This is actually perfectly OK
- #print STDERR "Warning: Symbol '",$a[0],"' redefined. old=",$ret{$a[0]},", new=",$a[1],"\n";
- }
- if ($max_num > $a[1]) {
- print STDERR "Warning: Number decreased from ",$max_num," to ",$a[1],"\n";
- }
- elsif ($max_num == $a[1]) {
- # This is actually perfectly OK
- #print STDERR "Warning: Symbol ",$a[0]," has same number as previous ",$prev,": ",$a[1],"\n";
- if ($a[0] eq $prev) {
- $prev_cnt++;
- $a[0] .= "{$prev_cnt}";
- }
- }
- else {
- $prev_cnt = 0;
- }
- if ($#a < 2) {
- # Existence will be proven later, in do_defs
- $ret{$a[0]}=$a[1];
- $num_noinfo++;
- } else {
- #Sanity check the version number
- if (defined $prevversion) {
- check_version_lte($prevversion, $a[2]);
- }
- check_version_lte($a[2], $currversion);
- $prevversion = $a[2];
- $ret{$a[0]}=$a[1]."\\".$a[2]."\\".$a[3]; # \\ is a special marker
- }
- $max_num = $a[1] if $a[1] > $max_num;
- $prev=$a[0];
- }
- if ($num_noinfo) {
- print STDERR "Warning: $num_noinfo symbols were without info." if $verbose || !$do_rewrite;
- if ($do_rewrite) {
- printf STDERR " The rewrite will fix this.\n" if $verbose;
- } else {
- printf STDERR " You should do a rewrite to fix this.\n";
- }
- }
- close(IN);
- return(%ret);
-}
-
-sub parse_number
-{
- (my $str, my $what) = @_;
- (my $n, my $v, my $i) = split(/\\/,$str);
- if ($what eq "n") {
- return $n;
- } else {
- return $i;
- }
-}
-
-sub rewrite_numbers
-{
- (*OUT,$name,*nums, at symbols)=@_;
- my $thing;
-
- my @r = grep(/^\w+(\{[0-9]+\})?\\.*?:.*?:\w+\(\w+\)/, at symbols);
- my $r; my %r; my %rsyms;
- foreach $r (@r) {
- (my $s, my $i) = split /\\/, $r;
- my $a = $1 if $i =~ /^.*?:.*?:\w+\((\w+)\)/;
- $i =~ s/^(.*?:.*?:\w+)\(\w+\)/$1/;
- $r{$a} = $s."\\".$i;
- $rsyms{$s} = 1;
- }
-
- my %syms = ();
- foreach $_ (@symbols) {
- (my $n, my $i) = split /\\/;
- $syms{$n} = 1;
- }
-
- my @s=sort {
- &parse_number($nums{$a},"n") <=> &parse_number($nums{$b},"n")
- || $a cmp $b
- } keys %nums;
- foreach $sym (@s) {
- (my $n, my $vers, my $i) = split /\\/, $nums{$sym};
- next if defined($i) && $i =~ /^.*?:.*?:\w+\(\w+\)/;
- next if defined($rsyms{$sym});
- print STDERR "DEBUG: rewrite_numbers for sym = ",$sym,": i = ",$i,", n = ",$n,", rsym{sym} = ",$rsyms{$sym},"syms{sym} = ",$syms{$sym},"\n" if $debug;
- $i="NOEXIST::FUNCTION:"
- if !defined($i) || $i eq "" || !defined($syms{$sym});
- my $s2 = $sym;
- $s2 =~ s/\{[0-9]+\}$//;
- printf OUT "%s%-39s %d\t%s\t%s\n","",$s2,$n,$vers,$i;
- if (exists $r{$sym}) {
- (my $s, $i) = split /\\/,$r{$sym};
- my $s2 = $s;
- $s2 =~ s/\{[0-9]+\}$//;
- printf OUT "%s%-39s %d\t%s\t%s\n","",$s2,$n,$vers,$i;
- }
- }
-}
-
-sub update_numbers
-{
- (*OUT,$name,*nums,my $start_num, my @symbols)=@_;
- my $new_syms = 0;
- my $basevers;
- my $vers;
-
- ($basevers, $vers) = get_openssl_version();
-
- my @r = grep(/^\w+(\{[0-9]+\})?\\.*?:.*?:\w+\(\w+\)/, at symbols);
- my $r; my %r; my %rsyms;
- foreach $r (@r) {
- (my $s, my $i) = split /\\/, $r;
- my $a = $1 if $i =~ /^.*?:.*?:\w+\((\w+)\)/;
- $i =~ s/^(.*?:.*?:\w+)\(\w+\)/$1/;
- $r{$a} = $s."\\".$i;
- $rsyms{$s} = 1;
- }
-
- foreach $sym (@symbols) {
- (my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
- next if $i =~ /^.*?:.*?:\w+\(\w+\)/;
- next if defined($rsyms{$sym});
- die "ERROR: Symbol $sym had no info attached to it."
- if $i eq "";
- if (!exists $nums{$s}) {
- $new_syms++;
- my $s2 = $s;
- $s2 =~ s/\{[0-9]+\}$//;
- printf OUT "%s%-39s %d\t%s\t%s\n","",$s2, ++$start_num,$vers,$i;
- if (exists $r{$s}) {
- ($s, $i) = split /\\/,$r{$s};
- $s =~ s/\{[0-9]+\}$//;
- printf OUT "%s%-39s %d\t%s\t%s\n","",$s, $start_num,$vers,$i;
- }
- }
- }
- if($new_syms) {
- print STDERR "$name: Added $new_syms new symbols\n";
- } else {
- print STDERR "$name: No new symbols added\n";
- }
-}
-
-sub check_existing
-{
- (*nums, my @symbols)=@_;
- my %existing; my @remaining;
- @remaining=();
- foreach $sym (@symbols) {
- (my $s, my $i) = $sym =~ /^(.*?)\\(.*)$/;
- $existing{$s}=1;
- }
- foreach $sym (keys %nums) {
- if (!exists $existing{$sym}) {
- push @remaining, $sym;
- }
- }
- if(@remaining) {
- print STDERR "The following symbols do not seem to exist:\n";
- foreach $sym (@remaining) {
- print STDERR "\t",$sym,"\n";
- }
- }
-}
-
-sub count_parens
-{
- my $line = shift(@_);
-
- my $open = $line =~ tr/\(//;
- my $close = $line =~ tr/\)//;
-
- return $open - $close;
-}
-
-#Parse opensslv.h to get the current version number. Also work out the base
-#version, i.e. the lowest version number that is binary compatible with this
-#version
-sub get_openssl_version()
-{
- my $fn = catfile($config{sourcedir},"include","openssl","opensslv.h");
- open (IN, "$fn") || die "Can't open opensslv.h";
-
- while(<IN>) {
- if (/OPENSSL_VERSION_TEXT\s+"OpenSSL (\d\.\d\.)(\d[a-z]*)(-| )/) {
- my $suffix = $2;
- (my $baseversion = $1) =~ s/\./_/g;
- close IN;
- return ($baseversion."0", $baseversion.$suffix);
- }
- }
- die "Can't find OpenSSL version number\n";
-}
-
-#Given an OpenSSL version number, calculate the next version number. If the
-#version number gets to a.b.czz then we go to a.b.(c+1)
-sub get_next_version()
-{
- my $thisversion = shift;
-
- my ($base, $letter) = $thisversion =~ /^(\d_\d_\d)([a-z]{0,2})$/;
-
- if ($letter eq "zz") {
- my $lastnum = substr($base, -1);
- return substr($base, 0, length($base)-1).(++$lastnum);
- }
- return $base.get_next_letter($letter);
+ if ($symvtextcount == 16) {
+ $firstcomma = '';
+ }
+ print <<"_____";
+ $firstcomma$pair->[0] -
+ ,$pair->[1] -
+_____
+ $symvtextcount += $pairtextlength;
+ }
+ print <<"_____";
+)
+_____
+
+ my ($libvmajor, $libvminor, $libvedit, $libvpatch) =
+ $config{version} =~ /^(\d+)_(\d+)_(\d+)([a-z]{0,2})-.*$/;
+ my $libvpatchnum = 0;
+ for (split '', $libvpatch // '') {
+ $libvpatchnum += ord(lc($_)) - 96;
+ # To compensate because the letter 'z' is always followed by another,
+ # i.e. doesn't add any value on its own
+ $libvpatchnum-- if lc($_) eq 'z';
+ }
+ my $match1 = $libvmajor * 100 + $libvminor;
+ my $match2 = $libvedit * 100 + $libvpatchnum;
+ print <<"_____";
+GSMATCH=LEQUAL,$match1,$match2
+_____
}
-#Given the letters off the end of an OpenSSL version string, calculate what
-#the letters for the next release would be.
-sub get_next_letter()
-{
- my $thisletter = shift;
- my $baseletter = "";
- my $endletter;
-
- if ($thisletter eq "") {
- return "a";
- }
- if ((length $thisletter) > 1) {
- ($baseletter, $endletter) = $thisletter =~ /([a-z]+)([a-z])/;
- } else {
- $endletter = $thisletter;
- }
-
- if ($endletter eq "z") {
- return $thisletter."a";
- } else {
- return $baseletter.(++$endletter);
- }
-}
+sub writer_ctest {
+ print <<'_____';
+/*
+ * Test file to check all DEF file symbols are present by trying
+ * to link to all of them. This is *not* intended to be run!
+ */
-#Check if a version is less than or equal to the current version. Its a fatal
-#error if not. They must also only differ in letters, or the last number (i.e.
-#the first two numbers must be the same)
-sub check_version_lte()
+int main()
{
- my ($testversion, $currversion) = @_;
- my $lentv;
- my $lencv;
- my $cvbase;
+_____
- my ($cvnums) = $currversion =~ /^(\d_\d_\d)[a-z]*$/;
- my ($tvnums) = $testversion =~ /^(\d_\d_\d)[a-z]*$/;
-
- #Die if we can't parse the version numbers or they don't look sane
- die "Invalid version number: $testversion and $currversion\n"
- if (!defined($cvnums) || !defined($tvnums)
- || length($cvnums) != 5
- || length($tvnums) != 5);
-
- #If the base versions (without letters) don't match check they only differ
- #in the last number
- if ($cvnums ne $tvnums) {
- die "Invalid version number: $testversion "
- ."for current version $currversion\n"
- if (substr($cvnums, 0, 4) ne substr($tvnums, 0, 4));
- return;
- }
- #If we get here then the base version (i.e. the numbers) are the same - they
- #only differ in the letters
-
- $lentv = length $testversion;
- $lencv = length $currversion;
-
- #If the testversion has more letters than the current version then it must
- #be later (or malformed)
- if ($lentv > $lencv) {
- die "Invalid version number: $testversion "
- ."is greater than $currversion\n";
- }
-
- #Get the last letter from the current version
- my ($cvletter) = $currversion =~ /([a-z])$/;
- if (defined $cvletter) {
- ($cvbase) = $currversion =~ /(\d_\d_\d[a-z]*)$cvletter$/;
- } else {
- $cvbase = $currversion;
- }
- die "Unable to parse version number $currversion" if (!defined $cvbase);
- my $tvbase;
- my ($tvletter) = $testversion =~ /([a-z])$/;
- if (defined $tvletter) {
- ($tvbase) = $testversion =~ /(\d_\d_\d[a-z]*)$tvletter$/;
- } else {
- $tvbase = $testversion;
- }
- die "Unable to parse version number $testversion" if (!defined $tvbase);
-
- if ($lencv > $lentv) {
- #If current version has more letters than testversion then testversion
- #minus the final letter must be a substring of the current version
- die "Invalid version number $testversion "
- ."is greater than $currversion or is invalid\n"
- if (index($cvbase, $tvbase) != 0);
- } else {
- #If both versions have the same number of letters then they must be
- #equal up to the last letter, and the last letter in testversion must
- #be less than or equal to the last letter in current version.
- die "Invalid version number $testversion "
- ."is greater than $currversion\n"
- if (($cvbase ne $tvbase) && ($tvletter gt $cvletter));
- }
+ for (@_) {
+ if ($_->type() eq 'VARIABLE') {
+ print "\textern int ", $_->name(), '; /* type unknown */ /* ', $_->number(), ' ', $_->version(), " */\n";
+ } else {
+ print "\textern int ", $_->name(), '(); /* type unknown */ /* ', $_->number(), ' ', $_->version(), " */\n";
+ }
+ }
+ print <<'_____';
}
-
-sub do_deprecated()
-{
- my ($decl, $plats, $algs) = @_;
- $decl =~ /^\s*(DEPRECATEDIN_\d+_\d+_\d+)\s*\((.*)\)\s*$/
- or die "Bad DEPRECATEDIN: $decl\n";
- my $info1 .= "#INFO:";
- $info1 .= join(',', @{$plats}) . ":";
- my $info2 = $info1;
- $info1 .= join(',',@{$algs}, $1) . ";";
- $info2 .= join(',',@{$algs}) . ";";
- return $info1 . $2 . ";" . $info2;
+_____
}
diff --git a/util/mknum.pl b/util/mknum.pl
new file mode 100644
index 0000000..a5f96b7
--- /dev/null
+++ b/util/mknum.pl
@@ -0,0 +1,125 @@
+
+#! /usr/bin/env perl
+# Copyright 2018 The OpenSSL Project Authors. All Rights Reserved.
+#
+# Licensed under the OpenSSL license (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;
+
+use Getopt::Long;
+use FindBin;
+use lib "$FindBin::Bin/perl";
+
+use OpenSSL::Ordinals;
+use OpenSSL::ParseC;
+
+my $ordinals_file = undef; # the ordinals file to use
+my $symhacks_file = undef; # a symbol hacking file (optional)
+my $version = undef; # the version to use for added symbols
+my $checkexist = 0; # (unsure yet)
+my $warnings = 1;
+my $verbose = 0;
+my $debug = 0;
+
+GetOptions('ordinals=s' => \$ordinals_file,
+ 'symhacks=s' => \$symhacks_file,
+ 'version=s' => \$version,
+ 'exist' => \$checkexist,
+ 'warnings!' => \$warnings,
+ 'verbose' => \$verbose,
+ 'debug' => \$debug)
+ or die "Error in command line arguments\n";
+
+die "Please supply ordinals file\n"
+ unless $ordinals_file;
+
+my $ordinals = OpenSSL::Ordinals->new(from => $ordinals_file,
+ warnings => $warnings,
+ verbose => $verbose,
+ debug => $debug);
+$ordinals->set_version($version);
+
+my %orig_names = ();
+%orig_names = map { $_->name() => 1 }
+ $ordinals->items(comparator => sub { $_[0] cmp $_[1] },
+ filter => sub { $_->exists() })
+ if $checkexist;
+
+# Invalidate all entries, they get revalidated when we re-check below
+$ordinals->invalidate();
+
+foreach my $f (($symhacks_file // (), @ARGV)) {
+ print STDERR $f," ","-" x (69 - length($f)),"\n" if $verbose;
+ open IN, $f || die "Couldn't open $f: $!\n";
+ foreach (parse(<IN>, { filename => $f,
+ warnings => $warnings,
+ verbose => $verbose,
+ debug => $debug })) {
+ $_->{value} = $_->{value}||"";
+ next if grep { $_ eq 'CONST_STRICT' } @{$_->{conds}};
+ printf STDERR "%s> %s%s : %s\n",
+ $_->{type},
+ $_->{name},
+ ($_->{type} eq 'M' && defined $symhacks_file && $f eq $symhacks_file
+ ? ' = ' . $_->{value}
+ : ''),
+ join(', ', @{$_->{conds}})
+ if $verbose;
+ if ($_->{type} eq 'M'
+ && defined $symhacks_file
+ && $f eq $symhacks_file
+ && $_->{value} =~ /^\w(?:\w|\d)*/) {
+ $ordinals->add_alias($_->{value}, $_->{name}, @{$_->{conds}});
+ } else {
+ next if $_->{returntype} =~ /\b(?:ossl_)inline/;
+ my $type = {
+ F => 'FUNCTION',
+ V => 'VARIABLE',
+ } -> {$_->{type}};
+ if ($type) {
+ $ordinals->add($_->{name}, $type, @{$_->{conds}});
+ }
+ }
+ }
+ close IN;
+}
+
+if ($checkexist) {
+ my %new_names = map { $_->name() => 1 }
+ $ordinals->items(comparator => sub { $_[0] cmp $_[1] },
+ filter => sub { $_->exists() });
+ # Eliminate common names
+ foreach (keys %orig_names) {
+ next unless exists $new_names{$_};
+ delete $orig_names{$_};
+ delete $new_names{$_};
+ }
+ if (%orig_names) {
+ print "The following symbols do not seem to exist in code:\n";
+ foreach (sort keys %orig_names) {
+ print "\t$_\n";
+ }
+ }
+ if (%new_names) {
+ print "The following existing symbols are not in ordinals file:\n";
+ foreach (sort keys %new_names) {
+ print "\t$_\n";
+ }
+ }
+} else {
+ $ordinals->rewrite();
+ my %stats = $ordinals->stats();
+ print STDERR
+ "${ordinals_file}: $stats{modified} old symbols have updated info\n"
+ if $stats{modified};
+ if ($stats{new}) {
+ print STDERR "${ordinals_file}: Added $stats{new} new symbols\n";
+ } else {
+ print STDERR "${ordinals_file}: No new symbols added\n";
+ }
+
+}
diff --git a/util/perl/OpenSSL/Ordinals.pm b/util/perl/OpenSSL/Ordinals.pm
new file mode 100644
index 0000000..07bdf81
--- /dev/null
+++ b/util/perl/OpenSSL/Ordinals.pm
@@ -0,0 +1,946 @@
+#! /usr/bin/env perl
+# Copyright 2018 The OpenSSL Project Authors. All Rights Reserved.
+#
+# Licensed under the OpenSSL license (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 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 =E<gt> value> pairs. Available
+options are:
+
+=over 4
+
+=item B<from =E<gt> 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
+ maxnum => 0, # Current highest allocated item number
+ contents => [], # Items, indexed by number
+ name2num => {}, # Name to number dictionary
+ aliases => {}, # Aliases cache.
+ stats => {}, # Statistics, see 'sub validate'
+ currversion => $opts{version} // '*', # '*' is for "we don't care"
+ debug => $opts{debug},
+ };
+ bless $instance, $class;
+
+ $instance->load($opts{from}) if defined($opts{from});
+
+ return $instance;
+}
+
+=item B<$ordinals-E<gt>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_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(from => $_);
+
+ my $num = $item->number();
+ croak "Disordered ordinals, $num < $max_num"
+ if $num < $max_num;
+ $max_num = $num;
+
+ push @{$tmp_contents[$item->number()]}, $item;
+ $tmp_name2num{$item->name()} = $item->number();
+ }
+ close F;
+
+ $self->{contents} = [ @tmp_contents ];
+ $self->{name2num} = { %tmp_name2num };
+ $self->{maxnum} = $max_num;
+ $self->{filename} = $filename;
+
+ # Make a deep copy, allowing {contents} to be an independent work array
+ foreach my $i (1..$max_num) {
+ if ($tmp_contents[$i]) {
+ $self->{loaded_contents}->[$i] =
+ [ map { OpenSSL::Ordinals::Item->new($_) }
+ @{$tmp_contents[$i]} ];
+ }
+ }
+ $self->{loaded_maxnum} = $max_num;
+ return 1;
+}
+
+=item B<$ordinals-E<gt>rewrite>
+
+If an ordinals file has been loaded, it gets rewritten with the data from
+the current work database.
+
+=cut
+
+sub rewrite {
+ my $self = shift;
+
+ $self->write($self->{filename});
+}
+
+=item B<$ordinals-E<gt>write FILENAME>
+
+Writes the current work database data to the ordinals file FILENAME.
+This also validates the data, see B<$ordinals-E<gt>validate> below.
+
+=cut
+
+sub write {
+ my $self = shift;
+ my $filename = shift;
+
+ croak "Undefined filename" unless defined($filename);
+
+ $self->validate();
+
+ open F, '>', $filename or croak "Unable to open $filename";
+ foreach ($self->items(by => by_number())) {
+ print F $_->to_string(),"\n";
+ }
+ close F;
+ $self->{filename} = $filename;
+ $self->{loaded_maxnum} = $self->{maxnum};
+ return 1;
+}
+
+=item B<$ordinals-E<gt>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 =E<gt> value> pairs.
+Available options are:
+
+=over 4
+
+=item B<sort =E<gt> 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 =E<gt> FILTERFUNCTION>
+
+FILTERFUNTION 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
+# - For platforms, both MUST hold the same ones, but with opposite values
+# - For features, both MUST hold the same ones.
+# If there's just one item, just put it in the slot of its number
+# In all other cases, something is wrong
+sub _putback {
+ my $self = shift;
+ my @items = @_;
+
+ if (scalar @items < 1 || scalar @items > 2) {
+ croak "Wrong number of items: ", scalar @items, " : ",
+ join(", ", map { $_->name() } @items), "\n";
+ }
+ if (scalar @items == 2) {
+ # Collect some data
+ my %numbers = ();
+ my %versions = ();
+ my %features = ();
+ foreach (@items) {
+ $numbers{$_->number()} = 1;
+ $versions{$_->version()} = 1;
+ foreach ($_->features()) {
+ $features{$_}++;
+ }
+ }
+
+ # Check that all items we're trying to put back have the same number
+ croak "Items don't have the same numeral: ",
+ join(", ", map { $_->name()." => ".$_->number() } @items), "\n"
+ if (scalar keys %numbers > 1);
+ croak "Items don't have the same version: ",
+ join(", ", map { $_->name()." => ".$_->version() } @items), "\n"
+ if (scalar keys %versions > 1);
+
+ # Check that both items run with the same features
+ foreach (@items) {
+ }
+ foreach (keys %features) {
+ delete $features{$_} if $features{$_} == 2;
+ }
+ croak "Features not in common between ",
+ $items[0]->name(), " and ", $items[1]->name(), ":",
+ join(", ", sort keys %features), "\n"
+ if %features;
+
+ # Check that all platforms exist in both items, and have opposite values
+ my @platforms = ( { $items[0]->platforms() },
+ { $items[1]->platforms() } );
+ foreach my $platform (keys %{$platforms[0]}) {
+ if (exists $platforms[1]->{$platform}) {
+ if ($platforms[0]->{$platform} != !$platforms[1]->{$platform}) {
+ croak "Platforms aren't opposite: ",
+ join(", ",
+ map { my %tmp_h = $_->platforms();
+ $_->name().":".$platform
+ ." => "
+ .$tmp_h{$platform} } @items),
+ "\n";
+ }
+
+ # We're done with these
+ delete $platforms[0]->{$platform};
+ delete $platforms[1]->{$platform};
+ }
+ }
+ # If there are any remaining platforms, something's wrong
+ if (%{$platforms[0]} || %{$platforms[0]}) {
+ croak "There are platforms not in common between ",
+ $items[0]->name(), " and ", $items[1]->name(), "\n";
+ }
+ }
+ $self->{contents}->[$items[0]->number()] = [ @items ];
+}
+
+sub _parse_platforms {
+ my $self = shift;
+ my @defs = @_;
+
+ my %platforms = ();
+ foreach (@defs) {
+ m{^(!)?};
+ my $op = !(defined $1 && $1 eq '!');
+ my $def = $';
+
+ if ($def =~ m{^_?WIN32$}) { $platforms{$&} = $op; }
+ if ($def =~ m{^__FreeBSD__$}) { $platforms{$&} = $op; }
+# For future support
+# if ($def =~ m{^__DragonFly__$}) { $platforms{$&} = $op; }
+# if ($def =~ m{^__OpenBSD__$}) { $platforms{$&} = $op; }
+# if ($def =~ m{^__NetBSD__$}) { $platforms{$&} = $op; }
+ if ($def =~
+ m{^OPENSSL_(EXPORT_VAR_AS_FUNCTION)$}) { $platforms{$1} = $op; }
+ if ($def =~ m{^OPENSSL_SYS_}) { $platforms{$'} = $op; }
+ }
+
+ return %platforms;
+}
+
+sub _parse_features {
+ my $self = shift;
+ my @defs = @_;
+
+ my %features = ();
+ foreach (@defs) {
+ m{^(!)?};
+ my $op = !(defined $1 && $1 eq '!');
+ my $def = $';
+
+ if ($def =~ m{^ZLIB$}) { $features{$&} = $op; }
+ if ($def =~ m{^OPENSSL_USE_}) { $features{$'} = $op; }
+ if ($def =~ m{^OPENSSL_NO_}) { $features{$'} = !$op; }
+ if ($def =~ m{^DEPRECATEDIN_(.*)$}) { $features{$&} = !$op; }
+ }
+
+ return %features;
+}
+
+=item B<$ordinals-E<gt>add NAME, TYPE, LIST>
+
+Adds a new item named NAME with the type TYPE, and a set of C macros in
+LIST that are expected to be defined or undefined to use this symbol, if
+any. For undefined macros, they each must be prefixed with a C<!>.
+
+If this symbol already exists in loaded data, it will be rewritten using
+the new input data, but will keep the same ordinal number and version.
+If it's entirely new, it will get a new number and the current default
+version. The new ordinal number is a simple increment from the last
+maximum number.
+
+=cut
+
+sub add {
+ my $self = shift;
+ my $name = shift;
+ my $type = shift; # FUNCTION or VARIABLE
+ my @defs = @_; # Macros from #ifdef and #ifndef
+ # (the latter prefixed with a '!')
+
+ # call signature for debug output
+ my $verbsig = "add('$name' , '$type' , [ " . join(', ', @defs) . " ])";
+
+ croak __PACKAGE__."->add got a bad type '$type'"
+ unless $type eq 'FUNCTION' || $type eq 'VARIABLE';
+
+ my %platforms = _parse_platforms(@defs);
+ my %features = _parse_features(@defs);
+
+ my @items = $self->items(filter => f_name($name));
+ my $version = @items ? $items[0]->version() : $self->{currversion};
+ my $number = @items ? $items[0]->number() : ++$self->{maxnum};
+ print STDERR "DEBUG[",__PACKAGE__,":add] $verbsig\n",
+ @items ? map { "\t".$_->to_string()."\n" } @items : "No previous items\n",
+ if $self->{debug};
+ @items = grep { $_->exists() } @items;
+
+ my $new_item =
+ OpenSSL::Ordinals::Item->new( name => $name,
+ type => $type,
+ number => $number,
+ version => $version,
+ exists => 1,
+ platforms => { %platforms },
+ features => [
+ grep { $features{$_} } keys %features
+ ] );
+
+ push @items, $new_item;
+ print STDERR "DEBUG[",__PACKAGE__,"::add] $verbsig\n", map { "\t".$_->to_string()."\n" } @items
+ if $self->{debug};
+ $self->_putback(@items);
+
+ # If an alias was defined beforehand, add an item for it now
+ my $alias = $self->{aliases}->{$name};
+ delete $self->{aliases}->{$name};
+
+ # For the caller to show
+ my @returns = ( $new_item );
+ push @returns, $self->add_alias($alias->{name}, $name, @{$alias->{defs}})
+ if defined $alias;
+ return @returns;
+}
+
+=item B<$ordinals-E<gt>add_alias ALIAS, NAME, LIST>
+
+Adds an alias ALIAS for the symbol NAME, and a set of C macros in LIST
+that are expected to be defined or undefined to use this symbol, if any.
+For undefined macros, they each must be prefixed with a C<!>.
+
+If this symbol already exists in loaded data, it will be rewritten using
+the new input data. Otherwise, the data will just be store away, to wait
+that the symbol NAME shows up.
+
+=cut
+
+sub add_alias {
+ my $self = shift;
+ my $alias = shift; # This is the alias being added
+ my $name = shift; # For this name (assuming it exists)
+ my @defs = @_; # Platform attributes for the alias
+
+ # call signature for debug output
+ my $verbsig =
+ "add_alias('$alias' , '$name' , [ " . join(', ', @defs) . " ])";
+
+ croak "You're kidding me..." if $alias eq $name;
+
+ my %platforms = _parse_platforms(@defs);
+ my %features = _parse_features(@defs);
+
+ croak "Alias with associated features is forbidden\n"
+ if %features;
+
+ my $f_byalias = f_name($alias);
+ my $f_byname = f_name($name);
+ my @items = $self->items(filter => $f_byalias);
+ foreach my $item ($self->items(filter => $f_byname)) {
+ push @items, $item unless grep { $_ == $item } @items;
+ }
+ @items = grep { $_->exists() } @items;
+
+ croak "Alias already exists ($alias => $name)"
+ if scalar @items > 1;
+ if (scalar @items == 0) {
+ # The item we want to alias for doesn't exist yet, so we cache the
+ # alias and hope the item we're making an alias of shows up later
+ $self->{aliases}->{$name} = { name => $alias, defs => [ @defs ] };
+
+ print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
+ "\tSet future alias $alias => $name\n"
+ if $self->{debug};
+ return ();
+ } elsif (scalar @items == 1) {
+ # The rule is that an alias is more or less a copy of the original
+ # item, just with another name. Also, the platforms given here are
+ # given to the original item as well, with opposite values.
+ my %alias_platforms = $items[0]->platforms();
+ foreach (keys %platforms) {
+ $alias_platforms{$_} = !$platforms{$_};
+ }
+ # We supposedly do now know how to do this... *ahem*
+ $items[0]->{platforms} = { %alias_platforms };
+
+ my $alias_item = OpenSSL::Ordinals::Item->new(
+ name => $alias,
+ type => $items[0]->type(),
+ number => $items[0]->number(),
+ version => $items[0]->version(),
+ exists => $items[0]->exists(),
+ platforms => { %platforms },
+ features => [ $items[0]->features() ]
+ );
+ push @items, $alias_item;
+
+ print STDERR "DEBUG[",__PACKAGE__,":add_alias] $verbsig\n",
+ map { "\t".$_->to_string()."\n" } @items
+ if $self->{debug};
+ $self->_putback(@items);
+
+ # For the caller to show
+ return ( $alias_item->to_string() );
+ }
+ croak "$name has an alias already (trying to add alias $alias)\n",
+ "\t", join(", ", map { $_->name() } @items), "\n";
+}
+
+=item B<$ordinals-E<gt>set_version VERSION>
+
+Sets the default version for new symbol to VERSION.
+
+=cut
+
+sub set_version {
+ my $self = shift;
+ my $version = shift;
+
+ $version //= '*';
+ $version =~ s|-.*||g;
+ $version =~ s|\.|_|g;
+ $self->{currversion} = $version;
+ foreach ($self->items(filter => sub { $_[0] eq '*' })) {
+ $_->{version} = $self->{currversion};
+ }
+ return 1;
+}
+
+=item B<$ordinals-E<gt>invalidate>
+
+Invalidates the whole working database. The practical effect is that all
+symbols are set to not exist, but are kept around in the database to retain
+ordinal numbers and versions.
+
+=cut
+
+sub invalidate {
+ my $self = shift;
+
+ foreach (@{$self->{contents}}) {
+ foreach (@{$_ // []}) {
+ $_->{exists} = 0;
+ }
+ }
+ $self->{stats} = {};
+}
+
+=item B<$ordinals-E<gt>validate>
+
+Validates the current working database by collection statistics on how many
+symbols were added and how many were changed. These numbers can be retrieved
+with B<$ordinals-E<gt>stats>.
+
+=cut
+
+sub validate {
+ my $self = shift;
+
+ $self->{stats} = {};
+ for my $i (1..$self->{maxnum}) {
+ if ($i > $self->{loaded_maxnum}
+ || (!@{$self->{loaded_contents}->[$i] // []}
+ && @{$self->{contents}->[$i] // []})) {
+ $self->{stats}->{new}++;
+ }
+ next if ($i > $self->{loaded_maxnum});
+
+ my @loaded_strings =
+ map { $_->to_string() } @{$self->{loaded_contents}->[$i] // []};
+ my @current_strings =
+ map { $_->to_string() } @{$self->{contents}->[$i] // []};
+
+ foreach my $str (@current_strings) {
+ @loaded_strings = grep { $str ne $_ } @loaded_strings;
+ }
+ if (@loaded_strings) {
+ $self->{stats}->{modified}++;
+ }
+ }
+}
+
+=item B<$ordinals-E<gt>stats>
+
+Returns the statistics that B<validate> calculate.
+
+=cut
+
+sub stats {
+ my $self = shift;
+
+ return %{$self->{stats}};
+}
+
+=back
+
+=head2 Data elements
+
+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 =E<gt> value> pairs.
+Available options are:
+
+=over 4
+
+=item B<from =E<gt> STRING>
+
+This will create a new item, 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<name =E<gt> STRING>, B<number =E<gt> NUMBER>, B<version =E<gt> STRING>,
+ B<exists =E<gt> BOOLEAN>, B<type =E<gt> STRING>,
+ B<platforms =E<gt> HASHref>, B<features =E<gt> LISTref>
+
+This will create a new item with data coming from the arguments.
+
+=back
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ if (ref($_[0]) eq $class) {
+ return $class->new( map { $_ => $_[0]->{$_} } keys %{$_[0]} );
+ }
+
+ my %opts = @_;
+
+ croak "No argument given" unless %opts;
+
+ my $instance = undef;
+ if ($opts{from}) {
+ my @a = split /\s+/, $opts{from};
+
+ croak "Badly formatted ordinals string: $opts{from}"
+ unless ( scalar @a == 4
+ && $a[0] =~ /^[A-Za-z_][A-Za-z_0-9]*$/
+ && $a[1] =~ /^\d+$/
+ && $a[2] =~ /^(?:\*|\d+_\d+_\d+(?:[a-z]{0,2}))$/
+ && $a[3] =~ /^
+ (?:NO)?EXIST:
+ [^:]*:
+ (?:FUNCTION|VARIABLE):
+ [^:]*
+ $
+ /x );
+
+ my @b = split /:/, $a[3];
+ %opts = ( name => $a[0],
+ number => $a[1],
+ version => $a[2],
+ exists => $b[0] eq 'EXIST',
+ platforms => { map { m|^(!)?|; $' => !$1 }
+ split /,/,$b[1] },
+ type => $b[2],
+ features => [ split /,/,$b[3] // '' ] );
+ }
+
+ if ($opts{name} && $opts{version} && defined $opts{exists} && $opts{type}
+ && ref($opts{platforms} // {}) eq 'HASH'
+ && ref($opts{features} // []) eq 'ARRAY') {
+ $instance = { name => $opts{name},
+ type => $opts{type},
+ number => $opts{number},
+ version => $opts{version},
+ exists => !!$opts{exists},
+ platforms => { %{$opts{platforms} // {}} },
+ features => [ sort @{$opts{features} // []} ] };
+ } else {
+ croak __PACKAGE__."->new() called with bad arguments\n".
+ join("", map { " $_\t=> ".$opts{$_}."\n" } sort keys %opts);
+ }
+
+ return bless $instance, $class;
+}
+
+sub DESTROY {
+}
+
+=item B<$item-E<gt>name>
+
+The symbol name for this item.
+
+=item B<$item-E<gt>number>
+
+The positional number for this item.
+
+=item B<$item-E<gt>version>
+
+The version number for this item. Please note that these version numbers
+have underscore (C<_>) as a separator the the version parts.
+
+=item B<$item-E<gt>exists>
+
+A boolean that tells if this symbol exists in code or not.
+
+=item B<$item-E<gt>platforms>
+
+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-E<gt>type>
+
+C<FUNCTION> or C<VARIABLE>, depending on what the symbol represents.
+Some platforms do not care about this, others do.
+
+=item B<$item-E<gt>features>
+
+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-E<gt>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();
+ return sprintf "%-39s %d\t%s\t%s:%s:%s:%s",
+ $self->name(),
+ $self->number(),
+ $self->version(),
+ $self->exists() ? 'EXIST' : 'NOEXIST',
+ join(',', (map { ($platforms{$_} ? '' : '!') . $_ }
+ sort keys %platforms)),
+ $self->type(),
+ join(',', @features);
+}
+
+=back
+
+=head2 Comparators and filters
+
+For the B<$ordinals-E<gt>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]->number() <=> $_[1]->number() };
+}
+
+=item B<by_version>
+
+Returns a comparator that will compare the version of two
+OpenSSL::Ordinals::Item objects.
+
+=cut
+
+sub by_version {
+ sub _ossl_versionsplit {
+ my $textversion = shift;
+ return $textversion if $textversion eq '*';
+ my ($major,$minor,$edit,$patch) =
+ $textversion =~ /^(\d+)_(\d+)_(\d+)([a-z]{0,2})$/;
+ return ($major,$minor,$edit,$patch);
+ }
+
+ return sub {
+ my @a_split = _ossl_versionsplit($_[0]->version());
+ my @b_split = _ossl_versionsplit($_[1]->version());
+ my $verdict = 0;
+ while (@a_split) {
+ # The last part is a letter sequence (or a '*')
+ if (scalar @a_split == 1) {
+ $verdict = $a_split[0] cmp $b_split[0];
+ } else {
+ $verdict = $a_split[0] <=> $b_split[0];
+ }
+ shift @a_split;
+ shift @b_split;
+ last unless $verdict == 0;
+ }
+ $verdict;
+ };
+}
+
+=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;
+
+ $version =~ s|\.|_|g if $version;
+ 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 at openssl.orgE<gt>.
+
+=cut
+
+1;
diff --git a/util/perl/OpenSSL/ParseC.pm b/util/perl/OpenSSL/ParseC.pm
new file mode 100644
index 0000000..ba2427c
--- /dev/null
+++ b/util/perl/OpenSSL/ParseC.pm
@@ -0,0 +1,1129 @@
+#! /usr/bin/env perl
+# Copyright 2018 The OpenSSL Project Authors. All Rights Reserved.
+#
+# Licensed under the OpenSSL license (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";
+ at ISA = qw(Exporter);
+ at 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.
+
+ { regexp => qr/#if OPENSSL_API_COMPAT(\S+)(0x[0-9a-fA-F]{8})L$/,
+ massager => sub {
+ my $op = $1;
+ my $v = hex($2);
+ if ($op ne '<' && $op ne '>=') {
+ die "Error: unacceptable operator $op: $_[0]\n";
+ }
+ my ($one, $major, $minor) =
+ ( ($v >> 28) & 0xf,
+ ($v >> 20) & 0xff,
+ ($v >> 12) & 0xff );
+ my $t = "DEPRECATEDIN_${one}_${major}_${minor}";
+ my $cond = $op eq '<' ? 'ifndef' : 'ifdef';
+ return (<<"EOF");
+#$cond $t
+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.
+
+ #####
+ # Global variable stuff
+ { regexp => qr/OPENSSL_DECLARE_GLOBAL<<<\((.*),(.*)\)>>>;/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_EXPORT_VAR_AS_FUNCTION
+OPENSSL_EXPORT $1 _shadow_$2;
+#else
+$1 *_shadow_$2(void);
+#endif
+EOF
+ },
+ },
+
+ #####
+ # Deprecated stuff, by OpenSSL release.
+
+ # We trick the parser by pretending that the declaration is wrapped in a
+ # check if the DEPRECATEDIN macro is defined or not. Callers of parse()
+ # will have to decide what to do with it.
+ { regexp => qr/(DEPRECATEDIN_\d+_\d+_\d+)<<<\((.*)\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef $1
+$2;
+#endif
+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<<<\((.*)\)>>>/,
+ 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<<<\((.*),(.*),(.*)\)>>>/,
+ 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/DEFINE_SPECIAL_STACK_OF<<<\((.*),(.*)\)>>>/,
+ 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<<<\((.*),(.*)\)>>>/,
+ 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)"); },
+ },
+ { regexp => qr/PREDECLARE_STACK_OF<<<\((.*)\)>>>/,
+ massager => sub { return ("STACK_OF($1);"); }
+ },
+ { regexp => qr/DECLARE_STACK_OF<<<\((.*)\)>>>/,
+ massager => sub { return ("STACK_OF($1);"); }
+ },
+ { regexp => qr/DECLARE_SPECIAL_STACK_OF<<<\((.*?),(.*?)\)>>>/,
+ massager => sub { return ("STACK_OF($1);"); }
+ },
+
+ #####
+ # ASN1 stuff
+
+ { regexp => qr/TYPEDEF_D2I_OF<<<\((.*)\)>>>/,
+ massager => sub {
+ return ("typedef $1 *d2i_of_$1($1 **,const unsigned char **,long)");
+ },
+ },
+ { regexp => qr/TYPEDEF_I2D_OF<<<\((.*)\)>>>/,
+ massager => sub {
+ return ("typedef $1 *i2d_of_$1($1 *,unsigned char **)");
+ },
+ },
+ { regexp => qr/TYPEDEF_D2I2D_OF<<<\((.*)\)>>>/,
+ massager => sub {
+ return ("TYPEDEF_D2I_OF($1); TYPEDEF_I2D_OF($1)");
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ITEM<<<\((.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+#ifndef OPENSSL_EXPORT_VAR_AS_FUNCTION
+OPENSSL_EXTERN const ASN1_ITEM *$1_it;
+#else
+const ASN1_ITEM *$1_it(void);
+#endif
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ENCODE_FUNCTIONS<<<\((.*),(.*),(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int d2i_$3(void);
+int i2d_$3(void);
+DECLARE_ASN1_ITEM($2)
+EOF
+ },
+ },
+ { regexp => qr/DECLARE_ASN1_ENCODE_FUNCTIONS_const<<<\((.*),(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int d2i_$2(void);
+int i2d_$2(void);
+DECLARE_ASN1_ITEM($2)
+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<<<\((.*),(.*)\)>>>/,
+ 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_fname<<<\((.*),(.*),(.*)\)>>>/,
+ massager => sub { return (<<"EOF");
+int d2i_$3(void);
+int i2d_$3(void);
+int $3_free(void);
+int $3_new(void);
+DECLARE_ASN1_ITEM($2)
+EOF
+ }
+ },
+ { regexp => qr/DECLARE_ASN1_FUNCTIONS(?:_const)?<<<\((.*)\)>>>/,
+ 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<<<\((.*),(.*)\)>>>/,
+ massager => sub {
+ return (<<"EOF");
+int $2_print_ctx(void);
+EOF
+ }
+ },
+ { regexp => qr/DECLARE_ASN1_SET_OF<<<\((.*)\)>>>/,
+ massager => sub { return (); }
+ },
+ { regexp => qr/DECLARE_PKCS12_SET_OF<<<\((.*)\)>>>/,
+ massager => sub { return (); }
+ },
+ { 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
+ },
+ },
+
+ #####
+ # PEM stuff
+ { 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(?|_read|_read_cb)<<<\((.*?),.*\)>>>/,
+ massager => sub { return (<<"EOF");
+#ifndef OPENSSL_NO_STDIO
+int PEM_read_$1(void);
+#endif
+int PEM_read_bio_$1(void);
+EOF
+ },
+ },
+
+ # 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); },
+ },
+ # 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
+ { 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)
+ ;
+ /x,
+ massager => sub {
+ return ("", $3, 'F', "", "$2(*$4)$5", all_conds())
+ if defined $1;
+ return ("", $3, 'F', "$2(*)$5", "$2(*$4)$5", all_conds()); }
+ },
+ # Function pointer declaration, or typedef thereof
+ { 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
+ { regexp => qr/(?:(typedef)\s?)? # Possible typedef ($1)
+ ((?:\w|\*|\s)*?) # Return type ($2)
+ \s? # Possible space
+ ([[:alpha:]_]\w*) # Function name ($3)
+ <<<(\(.*\))>>> # Parameters ($4)
+ ;
+ /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 $/, $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);
+}
More information about the openssl-commits
mailing list