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