#! /usr/bin/env perl
# Copyright 2018-2020 The OpenSSL Project Authors. All Rights Reserved.
#
# Licensed under the Apache License 2.0 (the "License").  You may not use
# this file except in compliance with the License.  You can obtain a copy
# in the file LICENSE in the source distribution or at
# https://www.openssl.org/source/license.html

package OpenSSL::ParseC;

use strict;
use warnings;

use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
$VERSION = "0.9";
@ISA = qw(Exporter);
@EXPORT = qw(parse);

# Global handler data
my @preprocessor_conds;         # A list of simple preprocessor conditions,
                                # each item being a list of macros defined
                                # or not defined.

# Handler helpers
sub all_conds {
    return map { ( @$_ ) } @preprocessor_conds;
}

# A list of handlers that will look at a "complete" string and try to
# figure out what to make of it.
# Each handler is a hash with the following keys:
#
# regexp                a regexp to compare the "complete" string with.
# checker               a function that does a more complex comparison.
#                       Use this instead of regexp if that isn't enough.
# massager              massages the "complete" string into an array with
#                       the following elements:
#
#                       [0]     String that needs further processing (this
#                               applies to typedefs of structs), or empty.
#                       [1]     The name of what was found.
#                       [2]     A character that denotes what type of thing
#                               this is: 'F' for function, 'S' for struct,
#                               'T' for typedef, 'M' for macro, 'V' for
#                               variable.
#                       [3]     Return type (only for type 'F' and 'V')
#                       [4]     Value (for type 'M') or signature (for type 'F',
#                               'V', 'T' or 'S')
#                       [5...]  The list of preprocessor conditions this is
#                               found in, as in checks for macro definitions
#                               (stored as the macro's name) or the absence
#                               of definition (stored as the macro's name
#                               prefixed with a '!'
#
#                       If the massager returns an empty list, it means the
#                       "complete" string has side effects but should otherwise
#                       be ignored.
#                       If the massager is undefined, the "complete" string
#                       should be ignored.
my @opensslcpphandlers = (
    ##################################################################
    # OpenSSL CPP specials
    #
    # These are used to convert certain pre-precessor expressions into
    # others that @cpphandlers have a better chance to understand.

    # This changes any OPENSSL_NO_DEPRECATED_x_y[_z] check to a check of
    # OPENSSL_NO_DEPRECATEDIN_x_y[_z].  That's due to <openssl/macros.h>
    # creating OPENSSL_NO_DEPRECATED_x_y[_z], but the ordinals files using
    # DEPRECATEDIN_x_y[_z].
    { regexp   => qr/#if(def|ndef) OPENSSL_NO_DEPRECATED_(\d+_\d+(?:_\d+)?)$/,
      massager => sub {
          return (<<"EOF");
#if$1 OPENSSL_NO_DEPRECATEDIN_$2
EOF
      }
   }
);
my @cpphandlers = (
    ##################################################################
    # CPP stuff

    { regexp   => qr/#ifdef ?(.*)/,
      massager => sub {
          my %opts;
          if (ref($_[$#_]) eq "HASH") {
              %opts = %{$_[$#_]};
              pop @_;
          }
          push @preprocessor_conds, [ $1 ];
          print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
              if $opts{debug};
          return ();
      },
    },
    { regexp   => qr/#ifndef ?(.*)/,
      massager => sub {
          my %opts;
          if (ref($_[$#_]) eq "HASH") {
              %opts = %{$_[$#_]};
              pop @_;
          }
          push @preprocessor_conds, [ '!'.$1 ];
          print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
              if $opts{debug};
          return ();
      },
    },
    { regexp   => qr/#if (0|1)/,
      massager => sub {
          my %opts;
          if (ref($_[$#_]) eq "HASH") {
              %opts = %{$_[$#_]};
              pop @_;
          }
          if ($1 eq "1") {
              push @preprocessor_conds, [ "TRUE" ];
          } else {
              push @preprocessor_conds, [ "!TRUE" ];
          }
          print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
              if $opts{debug};
          return ();
      },
    },
    { regexp   => qr/#if ?(.*)/,
      massager => sub {
          my %opts;
          if (ref($_[$#_]) eq "HASH") {
              %opts = %{$_[$#_]};
              pop @_;
          }
          my @results = ();
          my $conds = $1;
          if ($conds =~ m|^defined<<<\(([^\)]*)\)>>>(.*)$|) {
              push @results, $1; # Handle the simple case
              my $rest = $2;
              my $re = qr/^(?:\|\|defined<<<\([^\)]*\)>>>)*$/;
              print STDERR "DEBUG[",$opts{debug_type},"]: Matching '$rest' with '$re'\n"
                  if $opts{debug};
              if ($rest =~ m/$re/) {
                  my @rest = split /\|\|/, $rest;
                  shift @rest;
                  foreach (@rest) {
                      m|^defined<<<\(([^\)]*)\)>>>$|;
                      die "Something wrong...$opts{PLACE}" if $1 eq "";
                      push @results, $1;
                  }
              } else {
                  $conds =~ s/<<<|>>>//g;
                  warn "Warning: complicated #if expression(1): $conds$opts{PLACE}"
                      if $opts{warnings};
              }
          } elsif ($conds =~ m|^!defined<<<\(([^\)]*)\)>>>(.*)$|) {
              push @results, '!'.$1; # Handle the simple case
              my $rest = $2;
              my $re = qr/^(?:\&\&!defined<<<\([^\)]*\)>>>)*$/;
              print STDERR "DEBUG[",$opts{debug_type},"]: Matching '$rest' with '$re'\n"
                  if $opts{debug};
              if ($rest =~ m/$re/) {
                  my @rest = split /\&\&/, $rest;
                  shift @rest;
                  foreach (@rest) {
                      m|^!defined<<<\(([^\)]*)\)>>>$|;
                      die "Something wrong...$opts{PLACE}" if $1 eq "";
                      push @results, '!'.$1;
                  }
              } else {
                  $conds =~ s/<<<|>>>//g;
                  warn "Warning: complicated #if expression(2): $conds$opts{PLACE}"
                      if $opts{warnings};
              }
          } else {
              $conds =~ s/<<<|>>>//g;
              warn "Warning: complicated #if expression(3): $conds$opts{PLACE}"
                  if $opts{warnings};
          }
          print STDERR "DEBUG[",$opts{debug_type},"]: Added preprocessor conds: '", join("', '", @results), "'\n"
              if $opts{debug};
          push @preprocessor_conds, [ @results ];
          print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
              if $opts{debug};
          return ();
      },
    },
    { regexp   => qr/#elif (.*)/,
      massager => sub {
          my %opts;
          if (ref($_[$#_]) eq "HASH") {
              %opts = %{$_[$#_]};
              pop @_;
          }
          die "An #elif without corresponding condition$opts{PLACE}"
              if !@preprocessor_conds;
          pop @preprocessor_conds;
          print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
              if $opts{debug};
          return (<<"EOF");
#if $1
EOF
      },
    },
    { regexp   => qr/#else/,
      massager => sub {
          my %opts;
          if (ref($_[$#_]) eq "HASH") {
              %opts = %{$_[$#_]};
              pop @_;
          }
          die "An #else without corresponding condition$opts{PLACE}"
              if !@preprocessor_conds;
          # Invert all conditions on the last level
          my $stuff = pop @preprocessor_conds;
          push @preprocessor_conds, [
              map { m|^!(.*)$| ? $1 : '!'.$_ } @$stuff
          ];
          print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
              if $opts{debug};
          return ();
      },
    },
    { regexp   => qr/#endif ?/,
      massager => sub {
          my %opts;
          if (ref($_[$#_]) eq "HASH") {
              %opts = %{$_[$#_]};
              pop @_;
          }
          die "An #endif without corresponding condition$opts{PLACE}"
              if !@preprocessor_conds;
          pop @preprocessor_conds;
          print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
              if $opts{debug};
          return ();
      },
    },
    { regexp   => qr/#define ([[:alpha:]_]\w*)(<<<\(.*?\)>>>)?( (.*))?/,
      massager => sub {
          my $name = $1;
          my $params = $2;
          my $spaceval = $3||"";
          my $val = $4||"";
          return ("",
                  $1, 'M', "", $params ? "$name$params$spaceval" : $val,
                  all_conds()); }
    },
    { regexp   => qr/#.*/,
      massager => sub { return (); }
    },
    );

my @opensslchandlers = (
    ##################################################################
    # OpenSSL C specials
    #
    # They are really preprocessor stuff, but they look like C stuff
    # to this parser.  All of these do replacements, anything else is
    # an error.

    #####
    # Deprecated stuff, by OpenSSL release.

    # 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<<<\((.*),\s*(.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
STACK_OF($1);
typedef int (*sk_$1_compfunc)(const $3 * const *a, const $3 *const *b);
typedef void (*sk_$1_freefunc)($3 *a);
typedef $3 * (*sk_$1_copyfunc)(const $3 *a);
static ossl_inline int sk_$1_num(const STACK_OF($1) *sk);
static ossl_inline $2 *sk_$1_value(const STACK_OF($1) *sk, int idx);
static ossl_inline STACK_OF($1) *sk_$1_new(sk_$1_compfunc compare);
static ossl_inline STACK_OF($1) *sk_$1_new_null(void);
static ossl_inline STACK_OF($1) *sk_$1_new_reserve(sk_$1_compfunc compare,
                                                   int n);
static ossl_inline int sk_$1_reserve(STACK_OF($1) *sk, int n);
static ossl_inline void sk_$1_free(STACK_OF($1) *sk);
static ossl_inline void sk_$1_zero(STACK_OF($1) *sk);
static ossl_inline $2 *sk_$1_delete(STACK_OF($1) *sk, int i);
static ossl_inline $2 *sk_$1_delete_ptr(STACK_OF($1) *sk, $2 *ptr);
static ossl_inline int sk_$1_push(STACK_OF($1) *sk, $2 *ptr);
static ossl_inline int sk_$1_unshift(STACK_OF($1) *sk, $2 *ptr);
static ossl_inline $2 *sk_$1_pop(STACK_OF($1) *sk);
static ossl_inline $2 *sk_$1_shift(STACK_OF($1) *sk);
static ossl_inline void sk_$1_pop_free(STACK_OF($1) *sk,
                                       sk_$1_freefunc freefunc);
static ossl_inline int sk_$1_insert(STACK_OF($1) *sk, $2 *ptr, int idx);
static ossl_inline $2 *sk_$1_set(STACK_OF($1) *sk, int idx, $2 *ptr);
static ossl_inline int sk_$1_find(STACK_OF($1) *sk, $2 *ptr);
static ossl_inline int sk_$1_find_ex(STACK_OF($1) *sk, $2 *ptr);
static ossl_inline void sk_$1_sort(STACK_OF($1) *sk);
static ossl_inline int sk_$1_is_sorted(const STACK_OF($1) *sk);
static ossl_inline STACK_OF($1) * sk_$1_dup(const STACK_OF($1) *sk);
static ossl_inline STACK_OF($1) *sk_$1_deep_copy(const STACK_OF($1) *sk,
                                                 sk_$1_copyfunc copyfunc,
                                                 sk_$1_freefunc freefunc);
static ossl_inline sk_$1_compfunc sk_$1_set_cmp_func(STACK_OF($1) *sk,
                                                     sk_$1_compfunc compare);
EOF
      }
    },
    { regexp   => qr/DEFINE_SPECIAL_STACK_OF<<<\((.*),\s*(.*)\)>>>/,
      massager => sub { return ("SKM_DEFINE_STACK_OF($1,$2,$2)"); },
    },
    { regexp   => qr/DEFINE_STACK_OF<<<\((.*)\)>>>/,
      massager => sub { return ("SKM_DEFINE_STACK_OF($1,$1,$1)"); },
    },
    { regexp   => qr/DEFINE_SPECIAL_STACK_OF_CONST<<<\((.*),\s*(.*)\)>>>/,
      massager => sub { return ("SKM_DEFINE_STACK_OF($1,const $2,$2)"); },
    },
    { regexp   => qr/DEFINE_STACK_OF_CONST<<<\((.*)\)>>>/,
      massager => sub { return ("SKM_DEFINE_STACK_OF($1,const $1,$1)"); },
    },
    { regexp   => qr/DEFINE_STACK_OF_STRING<<<\((.*?)\)>>>/,
      massager => sub {
          return ("DEFINE_SPECIAL_STACK_OF(OPENSSL_STRING, char)");
      }
    },
    { regexp   => qr/DEFINE_STACK_OF_CSTRING<<<\((.*?)\)>>>/,
      massager => sub {
          return ("DEFINE_SPECIAL_STACK_OF_CONST(OPENSSL_CSTRING, char)");
      }
    },
    # DEFINE_OR_DECLARE macro calls must be interpretted as DEFINE macro
    # calls, because that's what they look like to the external apps.
    # (if that ever changes, we must change the substitutions to STACK_OF)
    { regexp   => qr/DEFINE_OR_DECLARE_STACK_OF<<<\((.*?)\)>>>/,
      massager => sub { return ("DEFINE_STACK_OF($1)"); }
    },
    { regexp   => qr/DEFINE_OR_DECLARE_STACK_OF_STRING<<<\(\)>>>/,
      massager => sub { return ("DEFINE_STACK_OF_STRING()"); },
    },
    { regexp   => qr/DEFINE_OR_DECLARE_STACK_OF_CSTRING<<<\(\)>>>/,
      massager => sub { return ("DEFINE_STACK_OF_CSTRING()"); },
    },

    #####
    # ASN1 stuff
    { regexp   => qr/DECLARE_ASN1_ITEM<<<\((.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
const ASN1_ITEM *$1_it(void);
EOF
      },
    },
    { regexp   => qr/DECLARE_ASN1_ENCODE_FUNCTIONS_only<<<\((.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int d2i_$2(void);
int i2d_$2(void);
EOF
      },
    },
    { regexp   => qr/DECLARE_ASN1_ENCODE_FUNCTIONS<<<\((.*),\s*(.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int d2i_$3(void);
int i2d_$3(void);
DECLARE_ASN1_ITEM($2)
EOF
      },
    },
    { regexp   => qr/DECLARE_ASN1_ENCODE_FUNCTIONS_name<<<\((.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int d2i_$2(void);
int i2d_$2(void);
DECLARE_ASN1_ITEM($2)
EOF
      },
    },
    { regexp   => qr/DECLARE_ASN1_ALLOC_FUNCTIONS_name<<<\((.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int $2_free(void);
int $2_new(void);
EOF
      },
    },
    { regexp   => qr/DECLARE_ASN1_ALLOC_FUNCTIONS<<<\((.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int $1_free(void);
int $1_new(void);
EOF
      },
    },
    { regexp   => qr/DECLARE_ASN1_FUNCTIONS_name<<<\((.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int d2i_$2(void);
int i2d_$2(void);
int $2_free(void);
int $2_new(void);
DECLARE_ASN1_ITEM($2)
EOF
      },
    },
    { regexp   => qr/DECLARE_ASN1_FUNCTIONS<<<\((.*)\)>>>/,
      massager => sub { return (<<"EOF");
int d2i_$1(void);
int i2d_$1(void);
int $1_free(void);
int $1_new(void);
DECLARE_ASN1_ITEM($1)
EOF
      }
    },
    { regexp   => qr/DECLARE_ASN1_NDEF_FUNCTION<<<\((.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int i2d_$1_NDEF(void);
EOF
      }
    },
    { regexp   => qr/DECLARE_ASN1_PRINT_FUNCTION<<<\((.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int $1_print_ctx(void);
EOF
      }
    },
    { regexp   => qr/DECLARE_ASN1_PRINT_FUNCTION_name<<<\((.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int $2_print_ctx(void);
EOF
      }
    },
    { regexp   => qr/DECLARE_ASN1_SET_OF<<<\((.*)\)>>>/,
      massager => sub { return (); }
    },
    { regexp   => qr/DECLARE_ASN1_DUP_FUNCTION<<<\((.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int $1_dup(void);
EOF
      }
    },
    { regexp   => qr/DECLARE_ASN1_DUP_FUNCTION_name<<<\((.*),\s*(.*)\)>>>/,
      massager => sub {
          return (<<"EOF");
int $2_dup(void);
EOF
      }
    },
    { 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); },
    },
    # any other extern is just ignored
    { regexp   => qr/^\s*                       # Any spaces before
                     extern                     # The keyword we look for
                     \b                         # word to non-word boundary
                     .*                         # Anything after
                     ;
                    /x,
      massager => sub { return (); },
    },
    # union, struct and enum definitions
    # Because this one might appear a little everywhere within type
    # definitions, we take it out and replace it with just
    # 'union|struct|enum name' while registering it.
    # This makes use of the parser trick to surround the outer braces
    # with <<< and >>>
    { regexp   => qr/(.*)                       # Anything before       ($1)
                     \b                         # word to non-word boundary
                     (union|struct|enum)        # The word used         ($2)
                     (?:\s([[:alpha:]_]\w*))?   # Struct or enum name   ($3)
                     <<<(\{.*?\})>>>            # Struct or enum definition ($4)
                     (.*)                       # Anything after        ($5)
                     ;
                    /x,
      massager => sub {
          my $before = $1;
          my $word = $2;
          my $name = $3
              || sprintf("__anon%03d", ++$anoncnt); # Anonymous struct
          my $definition = $4;
          my $after = $5;
          my $type = $word eq "struct" ? 'S' : 'E';
          if ($before ne "" || $after ne ";") {
              if ($after =~ m|^\w|) { $after = " ".$after; }
              return ("$before$word $name$after;",
                      "$word $name", $type, "", "$word$definition", all_conds());
          }
          # If there was no before nor after, make the return much simple
          return ("", "$word $name", $type, "", "$word$definition", all_conds());
      }
    },
    # Named struct and enum forward declarations
    # We really just ignore them, but we need to parse them or the variable
    # declaration handler further down will think it's a variable declaration.
    { regexp   => qr/^(union|struct|enum) ([[:alpha:]_]\w*);/,
      massager => sub { return (); }
    },
    # Function returning function pointer declaration
    { 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);
}