util/perl/OpenSSL/ParseC.pm

   1 #! /usr/bin/env perl
   2 # Copyright 2018 The OpenSSL Project Authors. All Rights Reserved.
   3 #
   4 # Licensed under the OpenSSL license (the "License").  You may not use
   5 # this file except in compliance with the License.  You can obtain a copy
   6 # in the file LICENSE in the source distribution or at
   7 # https://www.openssl.org/source/license.html
   8
   9 package OpenSSL::ParseC;
  10
  11 use strict;
  12 use warnings;
  13
  14 use Exporter;
  15 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  16 $VERSION = "0.9";
  17 @ISA = qw(Exporter);
  18 @EXPORT = qw(parse);
  19
  20 # Global handler data
  21 my @preprocessor_conds;         # A list of simple preprocessor conditions,
  22                                 # each item being a list of macros defined
  23                                 # or not defined.
  24
  25 # Handler helpers
  26 sub all_conds {
  27     return map { ( @$_ ) } @preprocessor_conds;
  28 }
  29
  30 # A list of handlers that will look at a "complete" string and try to
  31 # figure out what to make of it.
  32 # Each handler is a hash with the following keys:
  33 #
  34 # regexp                a regexp to compare the "complete" string with.
  35 # checker               a function that does a more complex comparison.
  36 #                       Use this instead of regexp if that isn't enough.
  37 # massager              massages the "complete" string into an array with
  38 #                       the following elements:
  39 #
  40 #                       [0]     String that needs further processing (this
  41 #                               applies to typedefs of structs), or empty.
  42 #                       [1]     The name of what was found.
  43 #                       [2]     A character that denotes what type of thing
  44 #                               this is: 'F' for function, 'S' for struct,
  45 #                               'T' for typedef, 'M' for macro, 'V' for
  46 #                               variable.
  47 #                       [3]     Return type (only for type 'F' and 'V')
  48 #                       [4]     Value (for type 'M') or signature (for type 'F',
  49 #                               'V', 'T' or 'S')
  50 #                       [5...]  The list of preprocessor conditions this is
  51 #                               found in, as in checks for macro definitions
  52 #                               (stored as the macro's name) or the absence
  53 #                               of definition (stored as the macro's name
  54 #                               prefixed with a '!'
  55 #
  56 #                       If the massager returns an empty list, it means the
  57 #                       "complete" string has side effects but should otherwise
  58 #                       be ignored.
  59 #                       If the massager is undefined, the "complete" string
  60 #                       should be ignored.
  61 my @opensslcpphandlers = (
  62     ##################################################################
  63     # OpenSSL CPP specials
  64     #
  65     # These are used to convert certain pre-precessor expressions into
  66     # others that @cpphandlers have a better chance to understand.
  67
  68     { regexp   => qr/#if OPENSSL_API_COMPAT(\S+)(0x[0-9a-fA-F]{8})L$/,
  69       massager => sub {
  70           my $op = $1;
  71           my $v = hex($2);
  72           if ($op ne '<' && $op ne '>=') {
  73               die "Error: unacceptable operator $op: $_[0]\n";
  74           }
  75           my ($major, $minor, $edit) =
  76               ( ($v >> 28) & 0xf,
  77                 ($v >> 20) & 0xff,
  78                 ($v >> 12) & 0xff );
  79           my $t = "DEPRECATEDIN_" .
  80               ($major <= 1
  81                ? "${major}_${minor}_${edit}"
  82                : "${major}");
  83           my $cond = $op eq '<' ? 'ifndef' : 'ifdef';
  84           return (<<"EOF");
  85 #$cond $t
  86 EOF
  87       }
  88    }
  89 );
  90 my @cpphandlers = (
  91     ##################################################################
  92     # CPP stuff
  93
  94     { regexp   => qr/#ifdef ?(.*)/,
  95       massager => sub {
  96           my %opts;
  97           if (ref($_[$#_]) eq "HASH") {
  98               %opts = %{$_[$#_]};
  99               pop @_;
 100           }
 101           push @preprocessor_conds, [ $1 ];
 102           print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
 103               if $opts{debug};
 104           return ();
 105       },
 106     },
 107     { regexp   => qr/#ifndef ?(.*)/,
 108       massager => sub {
 109           my %opts;
 110           if (ref($_[$#_]) eq "HASH") {
 111               %opts = %{$_[$#_]};
 112               pop @_;
 113           }
 114           push @preprocessor_conds, [ '!'.$1 ];
 115           print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
 116               if $opts{debug};
 117           return ();
 118       },
 119     },
 120     { regexp   => qr/#if (0|1)/,
 121       massager => sub {
 122           my %opts;
 123           if (ref($_[$#_]) eq "HASH") {
 124               %opts = %{$_[$#_]};
 125               pop @_;
 126           }
 127           if ($1 eq "1") {
 128               push @preprocessor_conds, [ "TRUE" ];
 129           } else {
 130               push @preprocessor_conds, [ "!TRUE" ];
 131           }
 132           print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
 133               if $opts{debug};
 134           return ();
 135       },
 136     },
 137     { regexp   => qr/#if ?(.*)/,
 138       massager => sub {
 139           my %opts;
 140           if (ref($_[$#_]) eq "HASH") {
 141               %opts = %{$_[$#_]};
 142               pop @_;
 143           }
 144           my @results = ();
 145           my $conds = $1;
 146           if ($conds =~ m|^defined<<<\(([^\)]*)\)>>>(.*)$|) {
 147               push @results, $1; # Handle the simple case
 148               my $rest = $2;
 149               my $re = qr/^(?:\|\|defined<<<\([^\)]*\)>>>)*$/;
 150               print STDERR "DEBUG[",$opts{debug_type},"]: Matching '$rest' with '$re'\n"
 151                   if $opts{debug};
 152               if ($rest =~ m/$re/) {
 153                   my @rest = split /\|\|/, $rest;
 154                   shift @rest;
 155                   foreach (@rest) {
 156                       m|^defined<<<\(([^\)]*)\)>>>$|;
 157                       die "Something wrong...$opts{PLACE}" if $1 eq "";
 158                       push @results, $1;
 159                   }
 160               } else {
 161                   $conds =~ s/<<<|>>>//g;
 162                   warn "Warning: complicated #if expression(1): $conds$opts{PLACE}"
 163                       if $opts{warnings};
 164               }
 165           } elsif ($conds =~ m|^!defined<<<\(([^\)]*)\)>>>(.*)$|) {
 166               push @results, '!'.$1; # Handle the simple case
 167               my $rest = $2;
 168               my $re = qr/^(?:\&\&!defined<<<\([^\)]*\)>>>)*$/;
 169               print STDERR "DEBUG[",$opts{debug_type},"]: Matching '$rest' with '$re'\n"
 170                   if $opts{debug};
 171               if ($rest =~ m/$re/) {
 172                   my @rest = split /\&\&/, $rest;
 173                   shift @rest;
 174                   foreach (@rest) {
 175                       m|^!defined<<<\(([^\)]*)\)>>>$|;
 176                       die "Something wrong...$opts{PLACE}" if $1 eq "";
 177                       push @results, '!'.$1;
 178                   }
 179               } else {
 180                   $conds =~ s/<<<|>>>//g;
 181                   warn "Warning: complicated #if expression(2): $conds$opts{PLACE}"
 182                       if $opts{warnings};
 183               }
 184           } else {
 185               $conds =~ s/<<<|>>>//g;
 186               warn "Warning: complicated #if expression(3): $conds$opts{PLACE}"
 187                   if $opts{warnings};
 188           }
 189           print STDERR "DEBUG[",$opts{debug_type},"]: Added preprocessor conds: '", join("', '", @results), "'\n"
 190               if $opts{debug};
 191           push @preprocessor_conds, [ @results ];
 192           print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
 193               if $opts{debug};
 194           return ();
 195       },
 196     },
 197     { regexp   => qr/#elif (.*)/,
 198       massager => sub {
 199           my %opts;
 200           if (ref($_[$#_]) eq "HASH") {
 201               %opts = %{$_[$#_]};
 202               pop @_;
 203           }
 204           die "An #elif without corresponding condition$opts{PLACE}"
 205               if !@preprocessor_conds;
 206           pop @preprocessor_conds;
 207           print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
 208               if $opts{debug};
 209           return (<<"EOF");
 210 #if $1
 211 EOF
 212       },
 213     },
 214     { regexp   => qr/#else/,
 215       massager => sub {
 216           my %opts;
 217           if (ref($_[$#_]) eq "HASH") {
 218               %opts = %{$_[$#_]};
 219               pop @_;
 220           }
 221           die "An #else without corresponding condition$opts{PLACE}"
 222               if !@preprocessor_conds;
 223           # Invert all conditions on the last level
 224           my $stuff = pop @preprocessor_conds;
 225           push @preprocessor_conds, [
 226               map { m|^!(.*)$| ? $1 : '!'.$_ } @$stuff
 227           ];
 228           print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
 229               if $opts{debug};
 230           return ();
 231       },
 232     },
 233     { regexp   => qr/#endif ?/,
 234       massager => sub {
 235           my %opts;
 236           if (ref($_[$#_]) eq "HASH") {
 237               %opts = %{$_[$#_]};
 238               pop @_;
 239           }
 240           die "An #endif without corresponding condition$opts{PLACE}"
 241               if !@preprocessor_conds;
 242           pop @preprocessor_conds;
 243           print STDERR "DEBUG[",$opts{debug_type},"]: preprocessor level: ", scalar(@preprocessor_conds), "\n"
 244               if $opts{debug};
 245           return ();
 246       },
 247     },
 248     { regexp   => qr/#define ([[:alpha:]_]\w*)(<<<\(.*?\)>>>)?( (.*))?/,
 249       massager => sub {
 250           my $name = $1;
 251           my $params = $2;
 252           my $spaceval = $3||"";
 253           my $val = $4||"";
 254           return ("",
 255                   $1, 'M', "", $params ? "$name$params$spaceval" : $val,
 256                   all_conds()); }
 257     },
 258     { regexp   => qr/#.*/,
 259       massager => sub { return (); }
 260     },
 261     );
 262
 263 my @opensslchandlers = (
 264     ##################################################################
 265     # OpenSSL C specials
 266     #
 267     # They are really preprocessor stuff, but they look like C stuff
 268     # to this parser.  All of these do replacements, anything else is
 269     # an error.
 270
 271     #####
 272     # Global variable stuff
 273     { regexp   => qr/OPENSSL_DECLARE_GLOBAL<<<\((.*),(.*)\)>>>;/,
 274       massager => sub { return (<<"EOF");
 275 #ifndef OPENSSL_EXPORT_VAR_AS_FUNCTION
 276 OPENSSL_EXPORT $1 _shadow_$2;
 277 #else
 278 $1 *_shadow_$2(void);
 279 #endif
 280 EOF
 281       },
 282     },
 283
 284     #####
 285     # Deprecated stuff, by OpenSSL release.
 286
 287     # We trick the parser by pretending that the declaration is wrapped in a
 288     # check if the DEPRECATEDIN macro is defined or not.  Callers of parse()
 289     # will have to decide what to do with it.
 290     { regexp   => qr/(DEPRECATEDIN_\d+(?:_\d+_\d+)?)<<<\((.*)\)>>>/,
 291       massager => sub { return (<<"EOF");
 292 #ifndef $1
 293 $2;
 294 #endif
 295 EOF
 296       },
 297     },
 298
 299     #####
 300     # LHASH stuff
 301
 302     # LHASH_OF(foo) is used as a type, but the chandlers won't take it
 303     # gracefully, so we expand it here.
 304     { regexp   => qr/(.*)\bLHASH_OF<<<\((.*?)\)>>>(.*)/,
 305       massager => sub { return ("$1struct lhash_st_$2$3"); }
 306     },
 307     { regexp   => qr/DEFINE_LHASH_OF<<<\((.*)\)>>>/,
 308       massager => sub {
 309           return (<<"EOF");
 310 static ossl_inline LHASH_OF($1) * lh_$1_new(unsigned long (*hfn)(const $1 *),
 311                                             int (*cfn)(const $1 *, const $1 *));
 312 static ossl_inline void lh_$1_free(LHASH_OF($1) *lh);
 313 static ossl_inline $1 *lh_$1_insert(LHASH_OF($1) *lh, $1 *d);
 314 static ossl_inline $1 *lh_$1_delete(LHASH_OF($1) *lh, const $1 *d);
 315 static ossl_inline $1 *lh_$1_retrieve(LHASH_OF($1) *lh, const $1 *d);
 316 static ossl_inline int lh_$1_error(LHASH_OF($1) *lh);
 317 static ossl_inline unsigned long lh_$1_num_items(LHASH_OF($1) *lh);
 318 static ossl_inline void lh_$1_node_stats_bio(const LHASH_OF($1) *lh, BIO *out);
 319 static ossl_inline void lh_$1_node_usage_stats_bio(const LHASH_OF($1) *lh,
 320                                                    BIO *out);
 321 static ossl_inline void lh_$1_stats_bio(const LHASH_OF($1) *lh, BIO *out);
 322 static ossl_inline unsigned long lh_$1_get_down_load(LHASH_OF($1) *lh);
 323 static ossl_inline void lh_$1_set_down_load(LHASH_OF($1) *lh, unsigned long dl);
 324 static ossl_inline void lh_$1_doall(LHASH_OF($1) *lh, void (*doall)($1 *));
 325 LHASH_OF($1)
 326 EOF
 327       }
 328      },
 329
 330     #####
 331     # STACK stuff
 332
 333     # STACK_OF(foo) is used as a type, but the chandlers won't take it
 334     # gracefully, so we expand it here.
 335     { regexp   => qr/(.*)\bSTACK_OF<<<\((.*?)\)>>>(.*)/,
 336       massager => sub { return ("$1struct stack_st_$2$3"); }
 337     },
 338 #    { regexp   => qr/(.*)\bSTACK_OF\((.*?)\)(.*)/,
 339 #      massager => sub {
 340 #          my $before = $1;
 341 #          my $stack_of = "struct stack_st_$2";
 342 #          my $after = $3;
 343 #          if ($after =~ m|^\w|) { $after = " ".$after; }
 344 #          return ("$before$stack_of$after");
 345 #      }
 346 #    },
 347     { regexp   => qr/SKM_DEFINE_STACK_OF<<<\((.*),(.*),(.*)\)>>>/,
 348       massager => sub {
 349           return (<<"EOF");
 350 STACK_OF($1);
 351 typedef int (*sk_$1_compfunc)(const $3 * const *a, const $3 *const *b);
 352 typedef void (*sk_$1_freefunc)($3 *a);
 353 typedef $3 * (*sk_$1_copyfunc)(const $3 *a);
 354 static ossl_inline int sk_$1_num(const STACK_OF($1) *sk);
 355 static ossl_inline $2 *sk_$1_value(const STACK_OF($1) *sk, int idx);
 356 static ossl_inline STACK_OF($1) *sk_$1_new(sk_$1_compfunc compare);
 357 static ossl_inline STACK_OF($1) *sk_$1_new_null(void);
 358 static ossl_inline STACK_OF($1) *sk_$1_new_reserve(sk_$1_compfunc compare,
 359                                                    int n);
 360 static ossl_inline int sk_$1_reserve(STACK_OF($1) *sk, int n);
 361 static ossl_inline void sk_$1_free(STACK_OF($1) *sk);
 362 static ossl_inline void sk_$1_zero(STACK_OF($1) *sk);
 363 static ossl_inline $2 *sk_$1_delete(STACK_OF($1) *sk, int i);
 364 static ossl_inline $2 *sk_$1_delete_ptr(STACK_OF($1) *sk, $2 *ptr);
 365 static ossl_inline int sk_$1_push(STACK_OF($1) *sk, $2 *ptr);
 366 static ossl_inline int sk_$1_unshift(STACK_OF($1) *sk, $2 *ptr);
 367 static ossl_inline $2 *sk_$1_pop(STACK_OF($1) *sk);
 368 static ossl_inline $2 *sk_$1_shift(STACK_OF($1) *sk);
 369 static ossl_inline void sk_$1_pop_free(STACK_OF($1) *sk,
 370                                        sk_$1_freefunc freefunc);
 371 static ossl_inline int sk_$1_insert(STACK_OF($1) *sk, $2 *ptr, int idx);
 372 static ossl_inline $2 *sk_$1_set(STACK_OF($1) *sk, int idx, $2 *ptr);
 373 static ossl_inline int sk_$1_find(STACK_OF($1) *sk, $2 *ptr);
 374 static ossl_inline int sk_$1_find_ex(STACK_OF($1) *sk, $2 *ptr);
 375 static ossl_inline void sk_$1_sort(STACK_OF($1) *sk);
 376 static ossl_inline int sk_$1_is_sorted(const STACK_OF($1) *sk);
 377 static ossl_inline STACK_OF($1) * sk_$1_dup(const STACK_OF($1) *sk);
 378 static ossl_inline STACK_OF($1) *sk_$1_deep_copy(const STACK_OF($1) *sk,
 379                                                  sk_$1_copyfunc copyfunc,
 380                                                  sk_$1_freefunc freefunc);
 381 static ossl_inline sk_$1_compfunc sk_$1_set_cmp_func(STACK_OF($1) *sk,
 382                                                      sk_$1_compfunc compare);
 383 EOF
 384       }
 385     },
 386     { regexp   => qr/DEFINE_SPECIAL_STACK_OF<<<\((.*),(.*)\)>>>/,
 387       massager => sub { return ("SKM_DEFINE_STACK_OF($1,$2,$2)"); },
 388     },
 389     { regexp   => qr/DEFINE_STACK_OF<<<\((.*)\)>>>/,
 390       massager => sub { return ("SKM_DEFINE_STACK_OF($1,$1,$1)"); },
 391     },
 392     { regexp   => qr/DEFINE_SPECIAL_STACK_OF_CONST<<<\((.*),(.*)\)>>>/,
 393       massager => sub { return ("SKM_DEFINE_STACK_OF($1,const $2,$2)"); },
 394     },
 395     { regexp   => qr/DEFINE_STACK_OF_CONST<<<\((.*)\)>>>/,
 396       massager => sub { return ("SKM_DEFINE_STACK_OF($1,const $1,$1)"); },
 397     },
 398     { regexp   => qr/PREDECLARE_STACK_OF<<<\((.*)\)>>>/,
 399       massager => sub { return ("STACK_OF($1);"); }
 400     },
 401     { regexp   => qr/DECLARE_STACK_OF<<<\((.*)\)>>>/,
 402       massager => sub { return ("STACK_OF($1);"); }
 403     },
 404     { regexp   => qr/DECLARE_SPECIAL_STACK_OF<<<\((.*?),(.*?)\)>>>/,
 405       massager => sub { return ("STACK_OF($1);"); }
 406      },
 407
 408     #####
 409     # ASN1 stuff
 410
 411     { regexp   => qr/TYPEDEF_D2I_OF<<<\((.*)\)>>>/,
 412       massager => sub {
 413           return ("typedef $1 *d2i_of_$1($1 **,const unsigned char **,long)");
 414       },
 415     },
 416     { regexp   => qr/TYPEDEF_I2D_OF<<<\((.*)\)>>>/,
 417       massager => sub {
 418           return ("typedef $1 *i2d_of_$1($1 *,unsigned char **)");
 419       },
 420     },
 421     { regexp   => qr/TYPEDEF_D2I2D_OF<<<\((.*)\)>>>/,
 422       massager => sub {
 423           return ("TYPEDEF_D2I_OF($1); TYPEDEF_I2D_OF($1)");
 424       },
 425     },
 426     { regexp   => qr/DECLARE_ASN1_ITEM<<<\((.*)\)>>>/,
 427       massager => sub {
 428           return (<<"EOF");
 429 #ifndef OPENSSL_EXPORT_VAR_AS_FUNCTION
 430 OPENSSL_EXTERN const ASN1_ITEM *$1_it;
 431 #else
 432 const ASN1_ITEM *$1_it(void);
 433 #endif
 434 EOF
 435       },
 436     },
 437     { regexp   => qr/DECLARE_ASN1_ENCODE_FUNCTIONS<<<\((.*),(.*),(.*)\)>>>/,
 438       massager => sub {
 439           return (<<"EOF");
 440 int d2i_$3(void);
 441 int i2d_$3(void);
 442 DECLARE_ASN1_ITEM($2)
 443 EOF
 444       },
 445     },
 446     { regexp   => qr/DECLARE_ASN1_ENCODE_FUNCTIONS_const<<<\((.*),(.*)\)>>>/,
 447       massager => sub {
 448           return (<<"EOF");
 449 int d2i_$2(void);
 450 int i2d_$2(void);
 451 DECLARE_ASN1_ITEM($2)
 452 EOF
 453       },
 454     },
 455     { regexp   => qr/DECLARE_ASN1_ALLOC_FUNCTIONS<<<\((.*)\)>>>/,
 456       massager => sub {
 457           return (<<"EOF");
 458 int $1_free(void);
 459 int $1_new(void);
 460 EOF
 461       },
 462     },
 463     { regexp   => qr/DECLARE_ASN1_FUNCTIONS_name<<<\((.*),(.*)\)>>>/,
 464       massager => sub {
 465           return (<<"EOF");
 466 int d2i_$2(void);
 467 int i2d_$2(void);
 468 int $2_free(void);
 469 int $2_new(void);
 470 DECLARE_ASN1_ITEM($2)
 471 EOF
 472       },
 473     },
 474     { regexp   => qr/DECLARE_ASN1_FUNCTIONS_fname<<<\((.*),(.*),(.*)\)>>>/,
 475       massager => sub { return (<<"EOF");
 476 int d2i_$3(void);
 477 int i2d_$3(void);
 478 int $3_free(void);
 479 int $3_new(void);
 480 DECLARE_ASN1_ITEM($2)
 481 EOF
 482       }
 483     },
 484     { regexp   => qr/DECLARE_ASN1_FUNCTIONS(?:_const)?<<<\((.*)\)>>>/,
 485       massager => sub { return (<<"EOF");
 486 int d2i_$1(void);
 487 int i2d_$1(void);
 488 int $1_free(void);
 489 int $1_new(void);
 490 DECLARE_ASN1_ITEM($1)
 491 EOF
 492       }
 493     },
 494     { regexp   => qr/DECLARE_ASN1_NDEF_FUNCTION<<<\((.*)\)>>>/,
 495       massager => sub {
 496           return (<<"EOF");
 497 int i2d_$1_NDEF(void);
 498 EOF
 499       }
 500     },
 501     { regexp   => qr/DECLARE_ASN1_PRINT_FUNCTION<<<\((.*)\)>>>/,
 502       massager => sub {
 503           return (<<"EOF");
 504 int $1_print_ctx(void);
 505 EOF
 506       }
 507     },
 508     { regexp   => qr/DECLARE_ASN1_PRINT_FUNCTION_name<<<\((.*),(.*)\)>>>/,
 509       massager => sub {
 510           return (<<"EOF");
 511 int $2_print_ctx(void);
 512 EOF
 513       }
 514     },
 515     { regexp   => qr/DECLARE_ASN1_SET_OF<<<\((.*)\)>>>/,
 516       massager => sub { return (); }
 517     },
 518     { regexp   => qr/DECLARE_PKCS12_SET_OF<<<\((.*)\)>>>/,
 519       massager => sub { return (); }
 520     },
 521     { regexp   => qr/DECLARE_PEM(?|_rw|_rw_cb|_rw_const)<<<\((.*?),.*\)>>>/,
 522       massager => sub { return (<<"EOF");
 523 #ifndef OPENSSL_NO_STDIO
 524 int PEM_read_$1(void);
 525 int PEM_write_$1(void);
 526 #endif
 527 int PEM_read_bio_$1(void);
 528 int PEM_write_bio_$1(void);
 529 EOF
 530       },
 531     },
 532
 533     #####
 534     # PEM stuff
 535     { regexp   => qr/DECLARE_PEM(?|_write|_write_cb|_write_const)<<<\((.*?),.*\)>>>/,
 536       massager => sub { return (<<"EOF");
 537 #ifndef OPENSSL_NO_STDIO
 538 int PEM_write_$1(void);
 539 #endif
 540 int PEM_write_bio_$1(void);
 541 EOF
 542       },
 543     },
 544     { regexp   => qr/DECLARE_PEM(?|_read|_read_cb)<<<\((.*?),.*\)>>>/,
 545       massager => sub { return (<<"EOF");
 546 #ifndef OPENSSL_NO_STDIO
 547 int PEM_read_$1(void);
 548 #endif
 549 int PEM_read_bio_$1(void);
 550 EOF
 551       },
 552     },
 553
 554     # Spurious stuff found in the OpenSSL headers
 555     # Usually, these are just macros that expand to, well, something
 556     { regexp   => qr/__NDK_FPABI__/,
 557       massager => sub { return (); }
 558     },
 559     );
 560
 561 my $anoncnt = 0;
 562
 563 my @chandlers = (
 564     ##################################################################
 565     # C stuff
 566
 567     # extern "C" of individual items
 568     # Note that the main parse function has a special hack for 'extern "C" {'
 569     # which can't be done in handlers
 570     # We simply ignore it.
 571     { regexp   => qr/extern "C" (.*;)/,
 572       massager => sub { return ($1); },
 573     },
 574     # union, struct and enum definitions
 575     # Because this one might appear a little everywhere within type
 576     # definitions, we take it out and replace it with just
 577     # 'union|struct|enum name' while registering it.
 578     # This makes use of the parser trick to surround the outer braces
 579     # with <<< and >>>
 580     { regexp   => qr/(.*)                       # Anything before       ($1)
 581                      \b                         # word to non-word boundary
 582                      (union|struct|enum)        # The word used         ($2)
 583                      (?:\s([[:alpha:]_]\w*))?   # Struct or enum name   ($3)
 584                      <<<(\{.*?\})>>>            # Struct or enum definition ($4)
 585                      (.*)                       # Anything after        ($5)
 586                      ;
 587                     /x,
 588       massager => sub {
 589           my $before = $1;
 590           my $word = $2;
 591           my $name = $3
 592               || sprintf("__anon%03d", ++$anoncnt); # Anonymous struct
 593           my $definition = $4;
 594           my $after = $5;
 595           my $type = $word eq "struct" ? 'S' : 'E';
 596           if ($before ne "" || $after ne ";") {
 597               if ($after =~ m|^\w|) { $after = " ".$after; }
 598               return ("$before$word $name$after;",
 599                       "$word $name", $type, "", "$word$definition", all_conds());
 600           }
 601           # If there was no before nor after, make the return much simple
 602           return ("", "$word $name", $type, "", "$word$definition", all_conds());
 603       }
 604     },
 605     # Named struct and enum forward declarations
 606     # We really just ignore them, but we need to parse them or the variable
 607     # declaration handler further down will think it's a variable declaration.
 608     { regexp   => qr/^(union|struct|enum) ([[:alpha:]_]\w*);/,
 609       massager => sub { return (); }
 610     },
 611     # Function returning function pointer declaration
 612     { regexp   => qr/(?:(typedef)\s?)?          # Possible typedef      ($1)
 613                      ((?:\w|\*|\s)*?)           # Return type           ($2)
 614                      \s?                        # Possible space
 615                      <<<\(\*
 616                      ([[:alpha:]_]\w*)          # Function name         ($3)
 617                      (\(.*\))                   # Parameters            ($4)
 618                      \)>>>
 619                      <<<(\(.*\))>>>             # F.p. parameters       ($5)
 620                      ;
 621                     /x,
 622       massager => sub {
 623           return ("", $3, 'F', "", "$2(*$4)$5", all_conds())
 624               if defined $1;
 625           return ("", $3, 'F', "$2(*)$5", "$2(*$4)$5", all_conds()); }
 626     },
 627     # Function pointer declaration, or typedef thereof
 628     { regexp   => qr/(?:(typedef)\s?)?          # Possible typedef      ($1)
 629                      ((?:\w|\*|\s)*?)           # Return type           ($2)
 630                      <<<\(\*([[:alpha:]_]\w*)\)>>> # T.d. or var name   ($3)
 631                      <<<(\(.*\))>>>             # F.p. parameters       ($4)
 632                      ;
 633                     /x,
 634       massager => sub {
 635           return ("", $3, 'T', "", "$2(*)$4", all_conds())
 636               if defined $1;
 637           return ("", $3, 'V', "$2(*)$4", "$2(*)$4", all_conds());
 638       },
 639     },
 640     # Function declaration, or typedef thereof
 641     { regexp   => qr/(?:(typedef)\s?)?          # Possible typedef      ($1)
 642                      ((?:\w|\*|\s)*?)           # Return type           ($2)
 643                      \s?                        # Possible space
 644                      ([[:alpha:]_]\w*)          # Function name         ($3)
 645                      <<<(\(.*\))>>>             # Parameters            ($4)
 646                      ;
 647                     /x,
 648       massager => sub {
 649           return ("", $3, 'T', "", "$2$4", all_conds())
 650               if defined $1;
 651           return ("", $3, 'F', $2, "$2$4", all_conds());
 652       },
 653     },
 654     # Variable declaration, including arrays, or typedef thereof
 655     { regexp   => qr/(?:(typedef)\s?)?          # Possible typedef      ($1)
 656                      ((?:\w|\*|\s)*?)           # Type                  ($2)
 657                      \s?                        # Possible space
 658                      ([[:alpha:]_]\w*)          # Variable name         ($3)
 659                      ((?:<<<\[[^\]]*\]>>>)*)    # Possible array declaration ($4)
 660                      ;
 661                     /x,
 662       massager => sub {
 663           return ("", $3, 'T', "", $2.($4||""), all_conds())
 664               if defined $1;
 665           return ("", $3, 'V', $2.($4||""), $2.($4||""), all_conds());
 666       },
 667     },
 668 );
 669
 670 # End handlers are almost the same as handlers, except they are run through
 671 # ONCE when the input has been parsed through.  These are used to check for
 672 # remaining stuff, such as an unfinished #ifdef and stuff like that that the
 673 # main parser can't check on its own.
 674 my @endhandlers = (
 675     { massager => sub {
 676         my %opts = %{$_[0]};
 677
 678         die "Unfinished preprocessor conditions levels: ",scalar(@preprocessor_conds),($opts{filename} ? " in file ".$opts{filename}: ""),$opts{PLACE}
 679             if @preprocessor_conds;
 680       }
 681     }
 682     );
 683
 684 # takes a list of strings that can each contain one or several lines of code
 685 # also takes a hash of options as last argument.
 686 #
 687 # returns a list of hashes with information:
 688 #
 689 #       name            name of the thing
 690 #       type            type, see the massage handler function
 691 #       returntype      return type of functions and variables
 692 #       value           value for macros, signature for functions, variables
 693 #                       and structs
 694 #       conds           preprocessor conditions (array ref)
 695
 696 sub parse {
 697     my %opts;
 698     if (ref($_[$#_]) eq "HASH") {
 699         %opts = %{$_[$#_]};
 700         pop @_;
 701     }
 702     my %state = (
 703         in_extern_C => 0,       # An exception to parenthesis processing.
 704         cpp_parens => [],       # A list of ending parens and braces found in
 705                                 # preprocessor directives
 706         c_parens => [],         # A list of ending parens and braces found in
 707                                 # C statements
 708         in_string => "",        # empty string when outside a string, otherwise
 709                                 # "'" or '"' depending on the starting quote.
 710         in_comment => "",       # empty string when outside a comment, otherwise
 711                                 # "/*" or "//" depending on the type of comment
 712                                 # found.  The latter will never be multiline
 713                                 # NOTE: in_string and in_comment will never be
 714                                 # true (in perl semantics) at the same time.
 715         current_line => 0,
 716         );
 717     my @result = ();
 718     my $normalized_line = "";   # $input_line, but normalized.  In essence, this
 719                                 # means that ALL whitespace is removed unless
 720                                 # it absolutely has to be present, and in that
 721                                 # case, there's only one space.
 722                                 # The cases where a space needs to stay present
 723                                 # are:
 724                                 # 1. between words
 725                                 # 2. between words and number
 726                                 # 3. after the first word of a preprocessor
 727                                 #    directive.
 728                                 # 4. for the #define directive, between the macro
 729                                 #    name/args and its value, so we end up with:
 730                                 #       #define FOO val
 731                                 #       #define BAR(x) something(x)
 732     my $collected_stmt = "";    # Where we're building up a C line until it's a
 733                                 # complete definition/declaration, as determined
 734                                 # by any handler being capable of matching it.
 735
 736     # We use $_ shamelessly when looking through @lines.
 737     # In case we find a \ at the end, we keep filling it up with more lines.
 738     $_ = undef;
 739
 740     foreach my $line (@_) {
 741         # split tries to be smart when a string ends with the thing we split on
 742         $line .= "\n" unless $line =~ m|\R$|;
 743         $line .= "#";
 744
 745         # We use ¦undef¦ as a marker for a new line from the file.
 746         # Since we convert one line to several and unshift that into @lines,
 747         # that's the only safe way we have to track the original lines
 748         my @lines = map { ( undef, $_ ) } split $/, $line;
 749
 750         # Remember that extra # we added above?  Now we remove it
 751         pop @lines;
 752         pop @lines;             # Don't forget the undef
 753
 754         while (@lines) {
 755             if (!defined($lines[0])) {
 756                 shift @lines;
 757                 $state{current_line}++;
 758                 if (!defined($_)) {
 759                     $opts{PLACE} = " at ".$opts{filename}." line ".$state{current_line}."\n";
 760                     $opts{PLACE2} = $opts{filename}.":".$state{current_line};
 761                 }
 762                 next;
 763             }
 764
 765             $_ = "" unless defined $_;
 766             $_ .= shift @lines;
 767
 768             if (m|\\$|) {
 769                 $_ = $`;
 770                 next;
 771             }
 772
 773             if ($opts{debug}) {
 774                 print STDERR "DEBUG:----------------------------\n";
 775                 print STDERR "DEBUG: \$_      = '$_'\n";
 776             }
 777
 778             ##########################################################
 779             # Now that we have a full line, let's process through it
 780             while(1) {
 781                 unless ($state{in_comment}) {
 782                     # Begin with checking if the current $normalized_line
 783                     # contains a preprocessor directive
 784                     # This is only done if we're not inside a comment and
 785                     # if it's a preprocessor directive and it's finished.
 786                     if ($normalized_line =~ m|^#| && $_ eq "") {
 787                         print STDERR "DEBUG[OPENSSL CPP]: \$normalized_line = '$normalized_line'\n"
 788                             if $opts{debug};
 789                         $opts{debug_type} = "OPENSSL CPP";
 790                         my @r = ( _run_handlers($normalized_line,
 791                                                 @opensslcpphandlers,
 792                                                 \%opts) );
 793                         if (shift @r) {
 794                             # Checking if there are lines to inject.
 795                             if (@r) {
 796                                 @r = split $/, (pop @r).$_;
 797                                 print STDERR "DEBUG[OPENSSL CPP]: injecting '", join("', '", @r),"'\n"
 798                                     if $opts{debug} && @r;
 799                                 @lines = ( @r, @lines );
 800
 801                                 $_ = "";
 802                             }
 803                         } else {
 804                             print STDERR "DEBUG[CPP]: \$normalized_line = '$normalized_line'\n"
 805                                 if $opts{debug};
 806                             $opts{debug_type} = "CPP";
 807                             my @r = ( _run_handlers($normalized_line,
 808                                                     @cpphandlers,
 809                                                     \%opts) );
 810                             if (shift @r) {
 811                                 if (ref($r[0]) eq "HASH") {
 812                                     push @result, shift @r;
 813                                 }
 814
 815                                 # Now, check if there are lines to inject.
 816                                 # Really, this should never happen, it IS a
 817                                 # preprocessor directive after all...
 818                                 if (@r) {
 819                                     @r = split $/, pop @r;
 820                                     print STDERR "DEBUG[CPP]: injecting '", join("', '", @r),"'\n"
 821                                     if $opts{debug} && @r;
 822                                     @lines = ( @r, @lines );
 823                                     $_ = "";
 824                                 }
 825                             }
 826                         }
 827
 828                         # Note: we simply ignore all directives that no
 829                         # handler matches
 830                         $normalized_line = "";
 831                     }
 832
 833                     # If the two strings end and start with a character that
 834                     # shouldn't get concatenated, add a space
 835                     my $space =
 836                         ($collected_stmt =~ m/(?:"|')$/
 837                          || ($collected_stmt =~ m/(?:\w|\d)$/
 838                              && $normalized_line =~ m/^(?:\w|\d)/)) ? " " : "";
 839
 840                     # Now, unless we're building up a preprocessor directive or
 841                     # are in the middle of a string, or the parens et al aren't
 842                     # balanced up yet, let's try and see if there's a OpenSSL
 843                     # or C handler that can make sense of what we have so far.
 844                     if ( $normalized_line !~ m|^#|
 845                          && ($collected_stmt ne "" || $normalized_line ne "")
 846                          && ! @{$state{c_parens}}
 847                          && ! $state{in_string} ) {
 848                         if ($opts{debug}) {
 849                             print STDERR "DEBUG[OPENSSL C]: \$collected_stmt  = '$collected_stmt'\n";
 850                             print STDERR "DEBUG[OPENSSL C]: \$normalized_line = '$normalized_line'\n";
 851                         }
 852                         $opts{debug_type} = "OPENSSL C";
 853                         my @r = ( _run_handlers($collected_stmt
 854                                                     .$space
 855                                                     .$normalized_line,
 856                                                 @opensslchandlers,
 857                                                 \%opts) );
 858                         if (shift @r) {
 859                             # Checking if there are lines to inject.
 860                             if (@r) {
 861                                 @r = split $/, (pop @r).$_;
 862                                 print STDERR "DEBUG[OPENSSL]: injecting '", join("', '", @r),"'\n"
 863                                     if $opts{debug} && @r;
 864                                 @lines = ( @r, @lines );
 865
 866                                 $_ = "";
 867                             }
 868                             $normalized_line = "";
 869                             $collected_stmt = "";
 870                         } else {
 871                             if ($opts{debug}) {
 872                                 print STDERR "DEBUG[C]: \$collected_stmt  = '$collected_stmt'\n";
 873                                 print STDERR "DEBUG[C]: \$normalized_line = '$normalized_line'\n";
 874                             }
 875                             $opts{debug_type} = "C";
 876                             my @r = ( _run_handlers($collected_stmt
 877                                                         .$space
 878                                                         .$normalized_line,
 879                                                     @chandlers,
 880                                                     \%opts) );
 881                             if (shift @r) {
 882                                 if (ref($r[0]) eq "HASH") {
 883                                     push @result, shift @r;
 884                                 }
 885
 886                                 # Checking if there are lines to inject.
 887                                 if (@r) {
 888                                     @r = split $/, (pop @r).$_;
 889                                     print STDERR "DEBUG[C]: injecting '", join("', '", @r),"'\n"
 890                                         if $opts{debug} && @r;
 891                                     @lines = ( @r, @lines );
 892
 893                                     $_ = "";
 894                                 }
 895                                 $normalized_line = "";
 896                                 $collected_stmt = "";
 897                             }
 898                         }
 899                     }
 900                     if ($_ eq "") {
 901                         $collected_stmt .= $space.$normalized_line;
 902                         $normalized_line = "";
 903                     }
 904                 }
 905
 906                 if ($_ eq "") {
 907                     $_ = undef;
 908                     last;
 909                 }
 910
 911                 # Take care of inside string first.
 912                 if ($state{in_string}) {
 913                     if (m/ (?:^|(?<!\\))        # Make sure it's not escaped
 914                            $state{in_string}    # Look for matching quote
 915                          /x) {
 916                         $normalized_line .= $`.$&;
 917                         $state{in_string} = "";
 918                         $_ = $';
 919                         next;
 920                     } else {
 921                         die "Unfinished string without continuation found$opts{PLACE}\n";
 922                     }
 923                 }
 924                 # ... or inside comments, whichever happens to apply
 925                 elsif ($state{in_comment}) {
 926
 927                     # This should never happen
 928                     die "Something went seriously wrong, multiline //???$opts{PLACE}\n"
 929                         if ($state{in_comment} eq "//");
 930
 931                     # A note: comments are simply discarded.
 932
 933                     if (m/ (?:^|(?<!\\))        # Make sure it's not escaped
 934                            \*\/                 # Look for C comment end
 935                          /x) {
 936                         $state{in_comment} = "";
 937                         $_ = $';
 938                         print STDERR "DEBUG: Found end of comment, followed by '$_'\n"
 939                             if $opts{debug};
 940                         next;
 941                     } else {
 942                         $_ = "";
 943                         next;
 944                     }
 945                 }
 946
 947                 # At this point, it's safe to remove leading whites, but
 948                 # we need to be careful with some preprocessor lines
 949                 if (m|^\s+|) {
 950                     my $rest = $';
 951                     my $space = "";
 952                     $space = " "
 953                         if ($normalized_line =~ m/^
 954                                                   \#define\s\w(?:\w|\d)*(?:<<<\([^\)]*\)>>>)?
 955                                                   | \#[a-z]+
 956                                                   $/x);
 957                     print STDERR "DEBUG: Processing leading spaces: \$normalized_line = '$normalized_line', \$space = '$space', \$rest = '$rest'\n"
 958                         if $opts{debug};
 959                     $_ = $space.$rest;
 960                 }
 961
 962                 my $parens =
 963                     $normalized_line =~ m|^#| ? 'cpp_parens' : 'c_parens';
 964                 (my $paren_singular = $parens) =~ s|s$||;
 965
 966                 # Now check for specific tokens, and if they are parens,
 967                 # check them against $state{$parens}.  Note that we surround
 968                 # the outermost parens with extra "<<<" and ">>>".  Those
 969                 # are for the benefit of handlers who to need to detect
 970                 # them, and they will be removed from the final output.
 971                 if (m|^[\{\[\(]|) {
 972                     my $body = $&;
 973                     $_ = $';
 974                     if (!@{$state{$parens}}) {
 975                         if ("$normalized_line$body" =~ m|^extern "C"\{$|) {
 976                             $state{in_extern_C} = 1;
 977                             print STDERR "DEBUG: found start of 'extern \"C\"' ($normalized_line$body)\n"
 978                                 if $opts{debug};
 979                             $normalized_line = "";
 980                         } else {
 981                             $normalized_line .= "<<<".$body;
 982                         }
 983                     } else {
 984                         $normalized_line .= $body;
 985                     }
 986
 987                     if ($normalized_line ne "") {
 988                         print STDERR "DEBUG: found $paren_singular start '$body'\n"
 989                             if $opts{debug};
 990                         $body =~ tr|\{\[\(|\}\]\)|;
 991                         print STDERR "DEBUG: pushing $paren_singular end '$body'\n"
 992                             if $opts{debug};
 993                         push @{$state{$parens}}, $body;
 994                     }
 995                 } elsif (m|^[\}\]\)]|) {
 996                     $_ = $';
 997
 998                     if (!@{$state{$parens}}
 999                         && $& eq '}' && $state{in_extern_C}) {
1000                         print STDERR "DEBUG: found end of 'extern \"C\"'\n"
1001                             if $opts{debug};
1002                         $state{in_extern_C} = 0;
1003                     } else {
1004                         print STDERR "DEBUG: Trying to match '$&' against '"
1005                             ,join("', '", @{$state{$parens}})
1006                             ,"'\n"
1007                             if $opts{debug};
1008                         die "Unmatched parentheses$opts{PLACE}\n"
1009                             unless (@{$state{$parens}}
1010                                     && pop @{$state{$parens}} eq $&);
1011                         if (!@{$state{$parens}}) {
1012                             $normalized_line .= $&.">>>";
1013                         } else {
1014                             $normalized_line .= $&;
1015                         }
1016                     }
1017                 } elsif (m|^["']|) { # string start
1018                     my $body = $&;
1019                     $_ = $';
1020
1021                     # We want to separate strings from \w and \d with one space.
1022                     $normalized_line .= " " if $normalized_line =~ m/(\w|\d)$/;
1023                     $normalized_line .= $body;
1024                     $state{in_string} = $body;
1025                 } elsif (m|^\/\*|) { # C style comment
1026                     print STDERR "DEBUG: found start of C style comment\n"
1027                         if $opts{debug};
1028                     $state{in_comment} = $&;
1029                     $_ = $';
1030                 } elsif (m|^\/\/|) { # C++ style comment
1031                     print STDERR "DEBUG: found C++ style comment\n"
1032                         if $opts{debug};
1033                     $_ = "";    # (just discard it entirely)
1034                 } elsif (m/^ (?| (?: 0[xX][[:xdigit:]]+ | 0[bB][01]+ | [0-9]+ )
1035                                  (?i: U | L | UL | LL | ULL )?
1036                                | [0-9]+\.[0-9]+(?:[eE][\-\+]\d+)? (?i: F | L)?
1037                                ) /x) {
1038                     print STDERR "DEBUG: Processing numbers: \$normalized_line = '$normalized_line', \$& = '$&', \$' = '$''\n"
1039                         if $opts{debug};
1040                     $normalized_line .= $&;
1041                     $_ = $';
1042                 } elsif (m/^[[:alpha:]_]\w*/) {
1043                     my $body = $&;
1044                     my $rest = $';
1045                     my $space = "";
1046
1047                     # Now, only add a space if it's needed to separate
1048                     # two \w characters, and we also surround strings with
1049                     # a space.  In this case, that's if $normalized_line ends
1050                     # with a \w, \d, " or '.
1051                     $space = " "
1052                         if ($normalized_line =~ m/("|')$/
1053                             || ($normalized_line =~ m/(\w|\d)$/
1054                                 && $body =~ m/^(\w|\d)/));
1055
1056                     print STDERR "DEBUG: Processing words: \$normalized_line = '$normalized_line', \$space = '$space', \$body = '$body', \$rest = '$rest'\n"
1057                         if $opts{debug};
1058                     $normalized_line .= $space.$body;
1059                     $_ = $rest;
1060                 } elsif (m|^(?:\\)?.|) { # Catch-all
1061                     $normalized_line .= $&;
1062                     $_ = $';
1063                 }
1064             }
1065         }
1066     }
1067     foreach my $handler (@endhandlers) {
1068         if ($handler->{massager}) {
1069             $handler->{massager}->(\%opts);
1070         }
1071     }
1072     return @result;
1073 }
1074
1075 # arg1:    line to check
1076 # arg2...: handlers to check
1077 # return undef when no handler matched
1078 sub _run_handlers {
1079     my %opts;
1080     if (ref($_[$#_]) eq "HASH") {
1081         %opts = %{$_[$#_]};
1082         pop @_;
1083     }
1084     my $line = shift;
1085     my @handlers = @_;
1086
1087     foreach my $handler (@handlers) {
1088         if ($handler->{regexp}
1089             && $line =~ m|^$handler->{regexp}$|) {
1090             if ($handler->{massager}) {
1091                 if ($opts{debug}) {
1092                     print STDERR "DEBUG[",$opts{debug_type},"]: Trying to handle '$line'\n";
1093                     print STDERR "DEBUG[",$opts{debug_type},"]: (matches /\^",$handler->{regexp},"\$/)\n";
1094                 }
1095                 my $saved_line = $line;
1096                 my @massaged =
1097                     map { s/(<<<|>>>)//g; $_ }
1098                     $handler->{massager}->($saved_line, \%opts);
1099                 print STDERR "DEBUG[",$opts{debug_type},"]: Got back '"
1100                     , join("', '", @massaged), "'\n"
1101                     if $opts{debug};
1102
1103                 # Because we may get back new lines to be
1104                 # injected before whatever else that follows,
1105                 # and the injected stuff might include
1106                 # preprocessor lines, we need to inject them
1107                 # in @lines and set $_ to the empty string to
1108                 # break out from the inner loops
1109                 my $injected_lines = shift @massaged || "";
1110
1111                 if (@massaged) {
1112                     return (1,
1113                             {
1114                                 name    => shift @massaged,
1115                                 type    => shift @massaged,
1116                                 returntype => shift @massaged,
1117                                 value   => shift @massaged,
1118                                 conds   => [ @massaged ]
1119                             },
1120                             $injected_lines
1121                         );
1122                 } else {
1123                     print STDERR "DEBUG[",$opts{debug_type},"]:   (ignore, possible side effects)\n"
1124                         if $opts{debug} && $injected_lines eq "";
1125                     return (1, $injected_lines);
1126                 }
1127             }
1128             return (1);
1129         }
1130     }
1131     return (0);
1132 }