File Coverage

blib/lib/MarpaX/Languages/C/AST/Grammar/ISO_ANSI_C_2011/Scan.pm
Criterion Covered Total %
statement 46 48 95.8
branch n/a
condition n/a
subroutine 16 16 100.0
pod n/a
total 62 64 96.8


line stmt bran cond sub pod time code
1 1     1   4 use strict;
  1         1  
  1         34  
2 1     1   3 use warnings FATAL => 'all';
  1         2  
  1         46  
3              
4             package MarpaX::Languages::C::AST::Grammar::ISO_ANSI_C_2011::Scan;
5 1     1   552 use parent qw/MarpaX::Languages::C::Scan/;
  1         278  
  1         4  
6              
7             # ABSTRACT: Scan C source
8              
9 1     1   574 use MarpaX::Languages::C::AST;
  1         2  
  1         32  
10 1     1   9 use Config;
  1         1  
  1         39  
11 1     1   4 use Carp qw/croak/;
  1         2  
  1         156  
12 1     1   5 use Data::Dumper;
  1         2  
  1         49  
13 1     1   649 use IPC::Cmd qw/run/;
  1         52029  
  1         61  
14 1     1   776 use File::Temp qw/tempfile/;
  1         7720  
  1         57  
15 1     1   6 use IO::File;
  1         2  
  1         120  
16 1     1   5 use Scalar::Util qw/blessed reftype/;
  1         3  
  1         37  
17 1     1   4 use Regexp::Common;
  1         1  
  1         9  
18 1     1   37590 use String::ShellQuote qw/shell_quote_best_effort/; # Not for Win32, but passes everywhere, so ok to use it like that
  1         665  
  1         71  
19 1     1   6 use Log::Any qw/$log/;
  1         1  
  1         56  
20             use constant {
21 1         79 LEXEME_POSITION_INDEX => 0,
22             LEXEME_LENGTH_INDEX => 1,
23             LEXEME_VALUE_INDEX => 2
24 1     1   78 };
  1         1  
25 1     1   454 use MarpaX::Languages::C::AST::Grammar::ISO_ANSI_C_2011::Scan::Actions;
  0            
  0            
26             use File::ShareDir::ProjectDistDir 1.0 ':all', strict => 1;
27             use File::Find qw/find/;
28             use File::Spec;
29             use File::Basename qw/basename/;
30             use Unicode::CaseFold;
31             use XML::LibXML;
32             use XML::LibXSLT;
33             use constant { TYPE => 0, QUALIFIER => 1, IDENTIFIER => 2, OTHER => 3, SKIPPED => 4, DECLARATOR => 5 };
34             our @type2String = qw/TYPE QUALIFIER IDENTIFIER OTHER SKIPPED DECLARATOR/;
35              
36             our $HAVE_SYS__INFO = eval 'use Sys::Info; 1' || 0;
37             our $HAVE_Win32__ShellQuote = _is_windows() ? (eval 'use Win32::ShellQuote qw/quote_native/; 1' || 0) : 0;
38             our $RESAMELINE = qr/(?:[ \t\v\f])*/; # i.e. WS* without \n
39             our $REDEFINE = qr/^${RESAMELINE}#${RESAMELINE}define${RESAMELINE}((\w+)(?>[^\n\\]*)(?>\\.[^\n\\]*)*)/ms; # dot-matches-all mode, keeping ^ meaningful
40             our $BALANCEDPARENS = qr/$RE{balanced}{-parens=>'()'}{-keep}/;
41              
42             our $VERSION = '0.45'; # VERSION
43              
44              
45             # ----------------------------------------------------------------------------------------
46              
47             sub new {
48             my ($class, %opts) = @_;
49              
50             if (exists($opts{filename}) && exists($opts{content})) {
51             croak 'filename and content are mutually exclusive';
52             }
53             if (! exists($opts{filename}) && ! exists($opts{content})) {
54             croak 'filename or content is required';
55             }
56              
57             my %astConfig = %opts;
58             foreach (qw/asDOM xpathDirectories xsltDirectories filename_filter enumType cpprun cppflags nocpp/) {
59             delete($astConfig{$_});
60             }
61             my $self = {
62             _asDOM => exists($opts{asDOM}) ? $opts{asDOM} : undef,
63             _xpathDirectories => exists($opts{xpathDirectories}) ? $opts{xpathDirectories} : [],
64             _xsltDirectories => exists($opts{xsltDirectories}) ? $opts{xsltDirectories} : [],
65             _filename_filter => exists($opts{filename_filter} ) ? $opts{filename_filter} : undef,
66             _enumType => exists($opts{enumType}) ? $opts{enumType} : 'int',
67             _cpprun => exists($opts{cpprun}) ? $opts{cpprun} : ($ENV{MARPAX_LANGUAGES_C_SCAN_CPPRUN} || $Config{cpprun}),
68             _cppflags => exists($opts{cppflags}) ? $opts{cppflags} : ($ENV{MARPAX_LANGUAGES_C_SCAN_CPPFLAGS} || $Config{cppflags}),
69             _nocpp => exists($opts{nocpp}) ? $opts{nocpp} : 0,
70             _astConfig => \%astConfig,
71             };
72              
73              
74             #
75             # For anonymous enums or structs, so that their names do not clash
76             #
77             $self->{_anonCount} = 0;
78              
79             if (exists($opts{content})) {
80             if (! defined($opts{content})) {
81             croak 'Undefined content';
82             }
83             $self->{_content2fh} = File::Temp->new(UNLINK => 1, SUFFIX => '.c');
84             my $filename = $self->{_orig_filename} = $self->{_content2fh}->filename;
85             #
86             # We open twice the temporary file to make sure it is not deleted
87             # physically on disk and still visible for our process
88             #
89             $self->{_tmpfh} = IO::File->new($filename, 'r') || croak "Cannot open $filename, $!";
90             print($self->{_content2fh}, $opts{content});
91             close($self->{_content2fh}) || warn "Cannot close $self->{_content2fh}, $!";
92             $self->{_content} = $opts{content};
93             } else {
94             if (! exists($opts{filename}) || ! defined($opts{filename})) {
95             croak 'Undefined filename';
96             }
97             my $filename = $self->{_orig_filename} = $opts{filename};
98             $self->{_tmpfh} = IO::File->new($filename, 'r') || croak "Cannot open $filename, $!";
99             }
100              
101             if (defined($self->{_filename_filter})) {
102             my $ref = reftype($self->{_filename_filter}) || '';
103             if ($ref) {
104             if ($ref ne 'REGEXP') {
105             croak 'filename_filter must be a scalar or a regular expression';
106             } else {
107             #
108             # For efficiency, instead of doing ref() or reftype() all the time, we will do exists()
109             #
110             $self->{_filename_filter_re} = $self->{_filename_filter};
111             }
112             }
113             }
114              
115             bless($self, $class);
116              
117             $self->_init();
118              
119             #
120             # We always produce the ast, and do heuristic processing, to liberate the temporary files.
121             #
122             $log->debugf('Producing AST');
123             $self->_ast();
124             $log->debugf('Doing heuristic analysis');
125             $self->_analyse_with_heuristics();
126             $log->debugf('Post-processing heuristics');
127             $self->_posprocess_heuristics();
128             #
129             # This will unlink temporary file
130             #
131             delete($self->{_tmpfh});
132             delete($self->{_content2fh});
133             #
134             # Delete what is left
135             #
136             delete($self->{_content});
137             delete($self->{_anonCount});
138              
139             return $self;
140             }
141              
142             # ----------------------------------------------------------------------------------------
143              
144              
145             sub ast {
146             my $self = shift;
147              
148             return $self->{_ast};
149             }
150              
151             # ----------------------------------------------------------------------------------------
152              
153              
154             sub astToString {
155             my $self = shift;
156              
157             return $self->{_asDOM} ? $self->ast()->toString(1) : Dumper($self->ast());
158             }
159              
160             # ----------------------------------------------------------------------------------------
161              
162              
163             sub get {
164             my ($self, $attribute) = @_;
165              
166             if ($attribute eq 'get' ||
167             $attribute eq 'new') {
168             croak "$attribute attribute is not supported";
169             }
170              
171             return $self->$attribute;
172             }
173              
174             # ----------------------------------------------------------------------------------------
175              
176              
177             sub includes {
178             my ($self) = @_;
179              
180             return $self->{_includes};
181             }
182              
183             # ----------------------------------------------------------------------------------------
184              
185              
186             sub defines_args {
187             my ($self) = @_;
188              
189             return $self->{_defines_args};
190             }
191              
192             # ----------------------------------------------------------------------------------------
193              
194              
195             sub defines_no_args {
196             my ($self) = @_;
197              
198             return $self->{_defines_no_args};
199             }
200              
201             # ----------------------------------------------------------------------------------------
202              
203              
204             sub strings {
205             my ($self) = @_;
206              
207             return $self->{_strings};
208             }
209              
210             # ----------------------------------------------------------------------------------------
211              
212              
213             sub macros {
214             my ($self) = @_;
215              
216             return $self->{_macros};
217             }
218              
219             # ----------------------------------------------------------------------------------------
220              
221              
222             sub fdecls {
223             my ($self) = @_;
224              
225             if (! defined($self->{_fdecls})) {
226             $self->_fdecls();
227             }
228              
229             return $self->{_fdecls};
230             }
231              
232             # ----------------------------------------------------------------------------------------
233              
234              
235             sub inlines {
236             my ($self) = @_;
237              
238             if (! defined($self->{_inlines})) {
239             $self->_inlines();
240             }
241              
242             return $self->{_inlines};
243             }
244              
245             # ----------------------------------------------------------------------------------------
246              
247              
248             sub parsed_fdecls {
249             my ($self) = @_;
250              
251             if (! defined($self->{_parsed_fdecls})) {
252             $self->_parsed_fdecls();
253             }
254              
255             return $self->{_parsed_fdecls};
256             }
257              
258             # ----------------------------------------------------------------------------------------
259              
260              
261             sub typedef_hash {
262             my ($self) = @_;
263              
264             if (! defined($self->{_typedef_hash})) {
265             $self->_typedef_hash();
266             }
267              
268             return $self->{_typedef_hash};
269             }
270              
271             # ----------------------------------------------------------------------------------------
272              
273              
274             sub typedef_texts {
275             my ($self) = @_;
276              
277             if (! defined($self->{_typedef_texts})) {
278             $self->_typedef_texts();
279             }
280              
281             return $self->{_typedef_texts};
282             }
283              
284             # ----------------------------------------------------------------------------------------
285              
286              
287             sub typedefs_maybe {
288             my ($self) = @_;
289              
290             if (! defined($self->{_typedefs_maybe})) {
291             $self->_typedefs_maybe();
292             }
293              
294             return $self->{_typedefs_maybe};
295             }
296              
297             # ----------------------------------------------------------------------------------------
298              
299              
300             sub vdecls {
301             my ($self) = @_;
302              
303             if (! defined($self->{_vdecls})) {
304             $self->_vdecls();
305             }
306              
307             return $self->{_vdecls};
308             }
309              
310             # ----------------------------------------------------------------------------------------
311              
312              
313             sub vdecl_hash {
314             my ($self) = @_;
315              
316             if (! defined($self->{_vdecl_hash})) {
317             $self->_vdecl_hash();
318             }
319              
320             return $self->{_vdecl_hash};
321             }
322              
323             # ----------------------------------------------------------------------------------------
324              
325              
326             sub typedef_structs {
327             my ($self) = @_;
328              
329             if (! defined($self->{_typedef_structs})) {
330             $self->_typedef_structs();
331             }
332              
333             return $self->{_typedef_structs};
334             }
335              
336             # ----------------------------------------------------------------------------------------
337              
338              
339             sub topDeclarations {
340             my ($self) = @_;
341              
342             if ($self->{_asDOM} && ! defined($self->{_topDeclarations})) {
343             $self->_topDeclarations();
344             }
345              
346             return $self->{_topDeclarations};
347             }
348              
349             # ----------------------------------------------------------------------------------------
350              
351              
352             sub cdecl {
353             my ($self) = @_;
354              
355             if ($self->{_asDOM} && ! defined($self->{_cdecl})) {
356             $self->_cdecl();
357             }
358              
359             return $self->{_cdecl};
360             }
361              
362              
363             # ----------------------------------------------------------------------------------------
364             # Brutal copy of String::ShellQuote::quote_literal
365              
366             sub _quote_literal {
367             my ($text, $force) = @_;
368              
369             # basic argument quoting. uses backslashes and quotes to escape
370             # everything.
371             if (!$force && $text ne '' && $text !~ /[ \t\n\x0b"]/) {
372             # no quoting needed
373             }
374             else {
375             $text =~ s{(\\*)(?="|\z)}{$1$1}g;
376             $text =~ s{"}{\\"}g;
377             $text = qq{"$text"};
378             }
379              
380             return $text;
381             }
382              
383             # ----------------------------------------------------------------------------------------
384              
385             sub _is_windows {
386             my $rc;
387              
388             if ($HAVE_SYS__INFO) {
389             my $info = Sys::Info->new;
390             my $os = $info->os();
391             $rc = $os->is_windows;
392             } else {
393             if ($^O =~ /win32/i) {
394             $rc = 1;
395             } else {
396             $rc = 0;
397             }
398             }
399              
400             return $rc;
401             }
402              
403             # ----------------------------------------------------------------------------------------
404              
405             sub _init {
406             my ($self) = @_;
407              
408             my $stdout_buf;
409              
410             if (! $self->{_nocpp}) {
411             #
412             # Note that, because we do not know if cpprun or cppflags contain multiple things
413             # we cannot use the array version of run(). So ye have to stringify ourself.
414             # It is assumed (and is the case with %Config value), that cpprun and cppflags
415             # will be already properly escaped.
416             # Remains the filename that we do ourself.
417             # Two big categories: Win32, others
418             #
419             my $quotedFilename;
420             my $cmd = "$self->{_cpprun} $self->{_cppflags} ";
421             if (_is_windows()) {
422             if ($HAVE_Win32__ShellQuote) {
423             $quotedFilename = quote_native($self->{_orig_filename});
424             } else {
425             $quotedFilename = _quote_literal($self->{_orig_filename}, 1);
426             }
427             } else {
428             $quotedFilename = shell_quote_best_effort($self->{_orig_filename});
429             }
430             $cmd .= $quotedFilename;
431              
432             my ($success, $error_code, undef, $stdout_bufp, $stderr_bufp) = run(command => $cmd);
433              
434             if (! $success) {
435             croak join('', @{$stderr_bufp});
436             }
437              
438             $stdout_buf = join('',@{$stdout_bufp});
439             } else {
440             $log->debugf('Disabling cpp step');
441             my $fh;
442             open($fh, '<', $self->{_orig_filename}) || croak "Cannot open $self->{_orig_filename}";
443             $stdout_buf = do {local $/; <$fh>;};
444             close($fh) || $log->warnf('Cannot close %s, %s', $self->{_orig_filename}, $!);
445             }
446              
447             $self->{_stdout_buf} = $stdout_buf;
448             $self->{_position2File} = {};
449             $self->{_sortedPosition2File} = [];
450              
451             }
452              
453             # ----------------------------------------------------------------------------------------
454              
455             sub _ast {
456             my ($self) = @_;
457              
458             #
459             # Temporary stuff
460             #
461             my %tmpHash = (_currentFile => undef, _includes => {});
462             #
463             # Get the AST, the lexeme callback will flag position2File to things of interest
464             #
465             $self->{_includes} = $self->{_asDOM} ? XML::LibXML::Document->new() : {};
466             $self->{_strings} = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
467             #
468             # Plus from our module: strings detection
469             #
470             my $value = MarpaX::Languages::C::AST->new
471             (
472             lexemeCallback => [ \&_lexemeCallback,
473             {self => $self,
474             tmpHashp => \%tmpHash,
475             }
476             ],
477             actionObject => sprintf('%s::%s', __PACKAGE__, 'Actions'),
478             nonTerminalSemantic => ':default ::= action => nonTerminalSemantic',
479             %{$self->{_astConfig}},
480             )->parse(\$self->{_stdout_buf})->value;
481             $self->{_ast} = ${$value};
482              
483             #
484             # For lookup, do a sorted version of position2File
485             #
486             $self->{_sortedPosition2File} = [ map { [ $_, $self->{_position2File}->{$_} ] } sort { $a <=> $b } keys %{$self->{_position2File}} ];
487             #
488             # Includes was a hash in %tmpHash
489             #
490             if ($self->{_asDOM}) {
491             foreach (sort keys %{$tmpHash{_includes}}) {
492             my $child = XML::LibXML::Element->new('include');
493             $self->{_includes}->addChild(XML::LibXML::Element->new('include'))->setAttribute('text', $_);
494             }
495             } else {
496             $self->{_includes} = [ sort keys %{$tmpHash{_includes}} ];
497             }
498              
499             if ($self->{_asDOM}) {
500             #
501             # We want to systematically provide a "text" attribute on all nodes
502             #
503             foreach ($self->ast()->findnodes($self->_xpath('allNodes.xpath'))) {
504             #
505             # In order to distringuish between a lexeme or not in the future, we remember
506             # if there was originally a lexeme -;
507             #
508             my $text = $_->getAttribute('text');
509             my $isLexeme = defined($text) ? 'true' : 'false';
510             $_->setAttribute('isLexeme', $isLexeme);
511             #
512             # And file information, which is acting as a filter
513             #
514             $self->_pushNodeFile(undef, $_, 1);
515             $self->_pushNodeString(undef, $_, 1);
516             }
517             }
518             }
519              
520             # ----------------------------------------------------------------------------------------
521              
522             sub _position2File {
523             my ($self, $position) = @_;
524              
525             my $file = '';
526             if (! exists($ENV{MARPAX_LANGUAGES_C_AST_T_SCAN})) {
527             #
528             # In the test suite, we cannot rely on filename that is compiler+OS dependant
529             #
530             foreach (@{$self->{_sortedPosition2File}}) {
531             if ($_->[0] > $position) {
532             last;
533             }
534             $file = $_->[1];
535             }
536             }
537              
538             return $file;
539             }
540              
541             # ----------------------------------------------------------------------------------------
542              
543             sub _xpath {
544             my ($self, $wantedFilename) = @_;
545              
546             if (! defined($self->{_xpath}->{$wantedFilename})) {
547             my $found = 0;
548             my @searchPath = (@{$self->{_xpathDirectories}}, File::Spec->catdir(dist_dir('MarpaX-Languages-C-AST'), 'xpath'));
549             foreach (@searchPath) {
550             #
551             # The fact that filesystem could be case tolerant is not an issue here
552             #
553             my $filename = File::Spec->canonpath(File::Spec->catfile($_, $wantedFilename));
554             $log->tracef('%s: trying with %s', $wantedFilename, $filename);
555             {
556             use filetest 'access';
557             if (-r $filename) {
558             my $fh;
559             if (! open($fh, '<', $filename)) {
560             #
561             # This should not happen
562             #
563             $log->warnf('Cannot open %s, %s', $filename, $!);
564             } else {
565             my $xpath = do {local $/; <$fh>};
566             if (! close($fh)) {
567             $log->warnf('Cannot close %s, %s', $filename, $!);
568             }
569             #
570             # Remove any blank outside of the xpath expression
571             #
572             $xpath =~ s/^\s*//;
573             $xpath =~ s/\s*$//;
574             $self->{_xpath}->{$wantedFilename} = eval {XML::LibXML::XPathExpression->new($xpath)};
575             if ($@) {
576             $log->warnf('Cannot evaluate xpath in %s, %s', $filename, $@);
577             #
578             # Make sure it is really undefined
579             #
580             $self->{_xpath}->{$wantedFilename} = undef;
581             } else {
582             #
583             # Done
584             #
585             $log->infof('%s evaluated using %s', $wantedFilename, $filename);
586             $found = 1;
587             last;
588             }
589             }
590             }
591             }
592             }
593             if (! $found) {
594             croak "Cannot find or evaluate \"$wantedFilename\". Search path was: [" . join(', ', map {"\"$_\""} (@searchPath)) . ']';
595             }
596             }
597             return $self->{_xpath}->{$wantedFilename};
598             }
599              
600             # ----------------------------------------------------------------------------------------
601              
602             sub _xslt {
603             my ($self, $wantedFilename) = @_;
604              
605             if (! defined($self->{_xslt}->{$wantedFilename})) {
606             my $found = 0;
607             my @searchPath = (@{$self->{_xsltDirectories}}, File::Spec->catdir(dist_dir('MarpaX-Languages-C-AST'), 'xslt'));
608             foreach (@searchPath) {
609             #
610             # The fact that filesystem could be case tolerant is not an issue here
611             #
612             my $filename = File::Spec->canonpath(File::Spec->catfile($_, $wantedFilename));
613             $log->tracef('%s: trying with %s', $wantedFilename, $filename);
614             {
615             use filetest 'access';
616             if (-r $filename) {
617             $self->{_xslt}->{$wantedFilename} = eval {XML::LibXSLT->new()->parse_stylesheet_file($filename)};
618             if ($@) {
619             $log->warnf('Cannot evaluate xslt in %s, %s', $filename, $@);
620             #
621             # Make sure it is really undefined
622             #
623             $self->{_xslt}->{$wantedFilename} = undef;
624             } else {
625             #
626             # Done
627             #
628             $log->infof('%s evaluated using %s', $wantedFilename, $filename);
629             $found = 1;
630             last;
631             }
632             }
633             }
634             }
635             if (! $found) {
636             croak "Cannot find or evaluate \"$wantedFilename\". Search path was: [" . join(', ', map {"\"$_\""} (@searchPath)) . ']';
637             }
638             }
639             return $self->{_xslt}->{$wantedFilename};
640             }
641              
642             # ----------------------------------------------------------------------------------------
643              
644             sub _pushNodeString {
645             my ($self, $outputp, $node, $setAttributes) = @_;
646              
647             $setAttributes //= 0;
648              
649             #
650             # Unless the node is already a lexeme, we have to search surrounding lexemes
651             # This routine assumes that $outputp is always a reference to either an array or a scalar
652             #
653             my $text = $node->getAttribute('text');
654             if (defined($text)) {
655             #
656             # Per def text, start and length attributes already exist
657             #
658             if (defined($outputp)) {
659             if (ref($outputp) eq 'ARRAY') {
660             push(@{$outputp}, $text);
661             } elsif (ref($outputp) eq 'SCALAR') {
662             ${$outputp} = $text;
663             } else {
664             croak "Expecting a reference to an array or a scalar, not a reference to " . (ref($outputp) || 'nothing');
665             }
666             }
667             return $text;
668             } else {
669             #
670             ## Get first and last lexemes positions
671             #
672             my $firstLexemeXpath = $self->_xpath('firstLexeme.xpath');
673             my $lastLexemeXpath = $self->_xpath('lastLexeme.xpath');
674              
675             my $firstLexeme = $node->findnodes($firstLexemeXpath);
676             my $lastLexeme = $node->findnodes($lastLexemeXpath);
677              
678             if ($firstLexeme && $lastLexeme) {
679             my $startPosition = $firstLexeme->[0]->findvalue('./@start');
680             my $endPosition = $lastLexeme->[0]->findvalue('./@start') + $lastLexeme->[0]->findvalue('./@length');
681             my $length = $endPosition - $startPosition;
682             my $text = substr($self->{_stdout_buf}, $startPosition, $length);
683             if (defined($outputp)) {
684             if (ref($outputp) eq 'ARRAY') {
685             push(@{$outputp}, $text);
686             } elsif (ref($outputp) eq 'SCALAR') {
687             ${$outputp} = $text;
688             } else {
689             croak "Expecting a reference to an array or a scalar, not a reference to " . (ref($outputp) || 'nothing');
690             }
691             }
692             if ($setAttributes) {
693             $node->setAttribute('start', $startPosition);
694             $node->setAttribute('length', $length);
695             $node->setAttribute('text', $text);
696             }
697             return $text;
698             } else {
699             return;
700             }
701             }
702             }
703              
704             # ----------------------------------------------------------------------------------------
705              
706             sub _fileOk {
707             my ($self, $file) = @_;
708              
709             my $rc = 0;
710             my ($volume, $directories, $filename) = File::Spec->splitpath($file);
711              
712             if (exists($self->{_filename_filter_re})) {
713             if (File::Spec->case_tolerant($volume)) {
714             $rc = ($file =~ /$self->{_filename_filter_re}/i) ? 1 : 0;
715             } else {
716             $rc = ($file =~ $self->{_filename_filter_re}) ? 1 : 0;
717             }
718             } elsif (defined($self->{_filename_filter})) {
719             #
720             # fc() crashed for me if $file is of zero length
721             #
722             if (length($file) <= 0) {
723             $rc = (length($self->{_filename_filter}) <= 0) ? 1 : 0;
724             } else {
725             if (File::Spec->case_tolerant($volume)) {
726             $rc = (fc($file) eq fc($self->{_filename_filter})) ? 1 : 0;
727             } else {
728             $rc = ($file eq $self->{_filename_filter}) ? 1 : 0;
729             }
730             }
731             } else {
732             $rc = 1;
733             }
734              
735             return $rc;
736             }
737              
738             # ----------------------------------------------------------------------------------------
739              
740             sub _pushNodeFile {
741             my ($self, $outputp, $node, $setAttribute) = @_;
742              
743             $setAttribute //= 0;
744              
745             #
746             # Unless the node is already a lexeme, we have to search surrounding lexemes
747             # This routine assumes that $outputp is always a reference to either an array or a scalar
748             #
749             # Get first lexeme position and return a false value only if filename filter is on and output does not match the filter
750             #
751             my $firstLexeme;
752             if ($node->getAttribute('text')) {
753             $firstLexeme = [$node];
754             } else {
755             my $firstLexemeXpath = $self->_xpath('firstLexeme.xpath');
756             $firstLexeme = $node->findnodes($firstLexemeXpath);
757             }
758             my $file = '';
759              
760             if ($firstLexeme) {
761             my $startPosition = $firstLexeme->[0]->findvalue('./@start');
762             $file = $self->_position2File($startPosition);
763             }
764              
765             if (defined($outputp)) {
766             if (ref($outputp) eq 'ARRAY') {
767             push(@{$outputp}, $file);
768             } elsif (ref($outputp) eq 'SCALAR') {
769             ${$outputp} = $file;
770             } else {
771             croak "Expecting a reference to an array or a scalar, not a reference to " . (ref($outputp) || 'nothing');
772             }
773             }
774              
775             if ($setAttribute) {
776             $node->setAttribute('file', $file);
777             }
778              
779             return $self->_fileOk($file);
780             }
781              
782             # ----------------------------------------------------------------------------------------
783              
784             sub _fdecls {
785             my ($self) = @_;
786              
787             if (! defined($self->{_fdecls})) {
788             #
789             # We rely on parsed_fdecls
790             #
791             $self->parsed_fdecls();
792             }
793              
794             return $self->{_fdecls};
795             }
796              
797             # ----------------------------------------------------------------------------------------
798              
799             sub _typedef_texts {
800             my ($self) = @_;
801              
802             if (! defined($self->{_typedef_texts})) {
803             #
804             # We rely on typedef_hash
805             #
806             $self->typedef_hash();
807             }
808              
809             return $self->{_typedef_texts};
810             }
811              
812             # ----------------------------------------------------------------------------------------
813              
814             sub _typedefs_maybe {
815             my ($self) = @_;
816              
817             if (! defined($self->{_typedefs_maybe})) {
818             #
819             # We rely on typedef_hash
820             #
821             $self->typedef_hash();
822             }
823              
824             return $self->{_typedefs_maybe};
825             }
826              
827             # ----------------------------------------------------------------------------------------
828              
829             sub _typedef_structs {
830             my ($self) = @_;
831              
832             if (! defined($self->{_typedef_structs})) {
833             #
834             # We rely on typedef_hash
835             #
836             $self->typedef_hash();
837             }
838              
839             return $self->{_typedef_structs};
840             }
841              
842             # ----------------------------------------------------------------------------------------
843              
844             sub _vdecls {
845             my ($self) = @_;
846              
847             if (! defined($self->{_vdecls})) {
848             #
849             # We rely on vdecl_hash
850             #
851             $self->vdecl_hash();
852             }
853              
854             return $self->{_vdecls};
855             }
856              
857             # ----------------------------------------------------------------------------------------
858              
859             sub _removeWord {
860             my ($self, $outputp, $toRemove) = @_;
861              
862             my $quotemeta = quotemeta($toRemove);
863             ${$outputp} =~ s/^\s*$quotemeta\b\s*//;
864             ${$outputp} =~ s/\s*\b$quotemeta\s*$//;
865             ${$outputp} =~ s/\s*\b$quotemeta\b\s*/ /;
866             }
867              
868             # ----------------------------------------------------------------------------------------
869              
870             sub _vdecl_hash {
871             my ($self) = @_;
872              
873             if (! defined($self->{_vdecl_hash})) {
874             $self->{_vdecl_hash} = $self->{_asDOM} ? XML::LibXML::Document->new() : {};
875             $self->{_vdecls} = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
876             #
877             # a vdecl is a "declaration" node
878             #
879             foreach my $declaration ($self->ast()->findnodes($self->_xpath('vdecl.xpath'))) {
880             my $file = '';
881             if (! $self->_pushNodeFile(\$file, $declaration)) {
882             next;
883             }
884             #
885             # Get first declarationSpecifiers
886             #
887             my @declarationSpecifiers = $declaration->findnodes($self->_xpath('firstDeclarationSpecifiers.xpath'));
888             if (! @declarationSpecifiers) {
889             #
890             # Could be a static assert declaration
891             #
892             next;
893             }
894             my $vdecl = '';
895             $self->_pushNodeString(\$vdecl, $declaration);
896             #
897             # vdecl_hash does not have the extern keyword.
898             #
899             my $textForHash;
900             $self->_pushNodeString(\$textForHash, $declarationSpecifiers[0]);
901             $self->_removeWord(\$textForHash, 'extern');
902              
903             if ($self->{_asDOM}) {
904             my $child = XML::LibXML::Element->new('vdecl');
905             $child->setAttribute('text', $vdecl);
906             $child->setAttribute('file', $file);
907             $self->{_vdecls}->addChild($child);
908             } else {
909             push(@{$self->{_vdecls}}, $vdecl);
910             }
911             #
912             # variable name
913             #
914             my @declarator = $declaration->findnodes($self->_xpath('declaration2Declarator.xpath'));
915             my @keys = ();
916             my @before = ();
917             my @after = ();
918             foreach (@declarator) {
919             my $declarator;
920             $self->_pushNodeString(\$declarator, $_);
921              
922             my @IDENTIFIER = $_->findnodes($self->_xpath('declarator2IDENTIFIER.xpath'));
923             if (@IDENTIFIER) {
924             $self->_pushNodeString(\@keys, $IDENTIFIER[0]);
925             } else {
926             my $anon = sprintf('ANON%d', $self->{_anonCount}++);
927             push(@keys, $anon);
928             }
929             $declarator =~ /(.*)$keys[-1](.*)/;
930             my $before = defined($-[1]) ? substr($declarator, $-[1], $+[1]-$-[1]) : '';
931             my $after = defined($-[2]) ? substr($declarator, $-[2], $+[2]-$-[2]) : '';
932             push(@before, ($before =~ /[^\s]/) ? ' ' . $before : '');
933             push(@after, ($after =~ /[^\s]/) ? ' ' . $after : '');
934             }
935             if (! @keys) {
936             push(@keys, sprintf('ANON%d', $self->{_anonCount}++));
937             push(@before, '');
938             push(@after, '');
939             }
940             foreach (0..$#keys) {
941             if ($self->{_asDOM}) {
942             my $child = XML::LibXML::Element->new('vdecl');
943             $child->setAttribute('before', $textForHash . $before[$_]);
944             $child->setAttribute('after', $after[$_]);
945             $child->setAttribute('id', $keys[$_]);
946             $child->setAttribute('file', $file);
947             $self->{_vdecl_hash}->addChild($child);
948             } else {
949             $self->{_vdecl_hash}->{$keys[$_]} = [ $textForHash . $before[$_], $after[$_] ];
950             }
951             }
952             }
953             }
954              
955             return $self->{_vdecl_hash};
956             }
957              
958             # ----------------------------------------------------------------------------------------
959              
960             sub _topDeclarations {
961             my ($self) = @_;
962              
963             if ($self->{_asDOM} && ! defined($self->{_topDeclarations})) {
964             $self->{_topDeclarations} = XML::LibXML::Document->new();
965             my $declarationList = XML::LibXML::Element->new('declarationList');
966             $self->{_topDeclarations}->addChild($declarationList);
967              
968             foreach ($self->ast()->findnodes($self->_xpath('topDeclarations.xpath'))) {
969             my $declaration = $_;
970             my $file;
971             if (! $self->_pushNodeFile(\$file, $_)) {
972             next;
973             }
974             $declarationList->addChild($declaration->cloneNode(1));
975             }
976             }
977             }
978              
979             # ----------------------------------------------------------------------------------------
980              
981             sub _addMissingIdentifiers {
982             my ($self, $declaration) = @_;
983             #
984             # Our model do not mind if we do not respect exactly the AST. In fact, it requires an IDENTIFIER
985             # or an IDENTIFIER_UNAMBIGUOUS (or ELLIPSIS exceptionnaly) to know when to "stop" when scanning nodes.
986             # We insert fake identifiers wherever needed.
987             #
988             foreach ($declaration->findnodes($self->_xpath('missingIdentifier.xpath'))) {
989             my $identifier = sprintf('__ANON%d', ++$self->{_cdeclAnonNb});
990             my $newNode = XML::LibXML::Element->new('ANON_IDENTIFIER');
991             $newNode->setAttribute('isLexeme', 'true');
992             $newNode->setAttribute('text', $identifier);
993             $newNode->setAttribute('start', -1);
994             $newNode->setAttribute('length', length($identifier));
995             if ($_->localname() eq 'SEMICOLON' || $_->localname() eq 'COLON') {
996             $log->debugf('_addMissingIdentifiers: %s: faking identifier %s before: %s', $declaration->getAttribute('text'), $identifier, $_->getAttribute('text'));
997             $_->parentNode->insertAfter($newNode, $_);
998             } else {
999             $log->debugf('_addMissingIdentifiers: %s: faking identifier %s after: %s', $declaration->getAttribute('text'), $identifier, $_->getAttribute('text'));
1000             $_->parentNode->insertAfter($newNode, $_);
1001             }
1002             }
1003             }
1004              
1005             # ----------------------------------------------------------------------------------------
1006              
1007             sub _removeEmptyStructDeclaration {
1008             my ($self, $declaration) = @_;
1009              
1010             foreach ($declaration->findnodes($self->_xpath('emptyStructDeclaration.xpath'))) {
1011             my $SEMICOLON = $_;
1012             my $structDeclaration = $SEMICOLON->parentNode();
1013             my $structDeclarationList = $structDeclaration->parentNode();
1014             my $structOrUnionSpecifier = $structDeclarationList->parentNode();
1015             $log->debugf('[-]_removeEmptyStructDeclaration: %s: removing empty declaration: %s', $structOrUnionSpecifier->getAttribute('text'), $_->getAttribute('text'));
1016             $structDeclarationList->removeChild($structDeclaration);
1017             #
1018             # /If/ $structDeclarationList then have no child, remove it as well
1019             #
1020             if (! $structDeclarationList->childNodes()) {
1021             $log->infof('_removeEmptyStructDeclaration: %s: removing empty declaration list', $structOrUnionSpecifier->getAttribute('text'));
1022             #
1023             # We remove it and the surrounding curlies
1024             #
1025             my $LCURLY = $structDeclarationList->previousSibling();
1026             my $RCURLY = $structDeclarationList->nextSibling();
1027             $structOrUnionSpecifier->removeChild($LCURLY);
1028             $structOrUnionSpecifier->removeChild($structDeclarationList);
1029             $structOrUnionSpecifier->removeChild($RCURLY);
1030             }
1031             }
1032             }
1033              
1034             # ----------------------------------------------------------------------------------------
1035              
1036             sub _recoverCommas {
1037             my ($self, $declaration) = @_;
1038              
1039             foreach ($declaration->findnodes($self->_xpath('missingComma.xpath'))) {
1040             my $i = 0;
1041             my $previousNode;
1042             foreach ($_->childNodes()) {
1043             if ($i > 0) {
1044             $log->debugf('_recoverCommas: %s: restoring comma lexeme after child No %d "%s"', $declaration->getAttribute('text'), $i - 1, $previousNode->getAttribute('text'));
1045             my $newNode = XML::LibXML::Element->new('COMMA');
1046             $newNode->setAttribute('isLexeme', 'true');
1047             $newNode->setAttribute('text', ',');
1048             $newNode->setAttribute('start', $previousNode->getAttribute('start') + $previousNode->getAttribute('length'));
1049             $newNode->setAttribute('length', $_->getAttribute('start') - $previousNode->getAttribute('start'));
1050             $previousNode->parentNode->insertAfter($newNode, $previousNode);
1051             }
1052             ++$i;
1053             $previousNode = $_;
1054             }
1055             }
1056             }
1057              
1058             # ----------------------------------------------------------------------------------------
1059              
1060             sub _simplifyEnumerators {
1061             my ($self, $declaration) = @_;
1062              
1063             foreach ($declaration->findnodes($self->_xpath('enumerators.xpath'))) {
1064             my $i = 0;
1065             my $firstChild = $_->firstChild();
1066             my $EQUAL = $firstChild->nextSibling();
1067             if (defined($EQUAL)) {
1068             my $constantExpression = $EQUAL->nextSibling();
1069             $log->debugf('_simplifyEnumerators: %s: removing constant expression "%s %s"', $_->getAttribute('text'), $EQUAL->getAttribute('text'), $constantExpression->getAttribute('text'));
1070             $_->removeChild($EQUAL);
1071             $_->removeChild($constantExpression);
1072             }
1073             }
1074             }
1075              
1076             # ----------------------------------------------------------------------------------------
1077              
1078             sub _simplifyInitDeclarators {
1079             my ($self, $declaration) = @_;
1080              
1081             foreach ($declaration->findnodes($self->_xpath('initDeclarators.xpath'))) {
1082             my $i = 0;
1083             my $firstChild = $_->firstChild();
1084             my $EQUAL = $firstChild->nextSibling();
1085             if (defined($EQUAL)) {
1086             my $initializer = $EQUAL->nextSibling();
1087             $log->debugf('_simplifyInitDeclarators: %s: removing initializer expression "%s %s"', $_->getAttribute('text'), $EQUAL->getAttribute('text'), $initializer->getAttribute('text'));
1088             $_->removeChild($EQUAL);
1089             $_->removeChild($initializer);
1090             }
1091             }
1092             }
1093              
1094             # ----------------------------------------------------------------------------------------
1095              
1096             sub _cdecl {
1097             my ($self) = @_;
1098              
1099             if ($self->{_asDOM} && ! defined($self->{_cdecl})) {
1100             $self->{_cdeclAnonNb} = 0;
1101             $self->{_cdecl} = [];
1102             #
1103             # We will analyse topDeclarations
1104             #
1105             foreach ($self->topDeclarations()->firstChild()->childNodes()) {
1106             #
1107             # We change the DOM before processing it, so better to work on a clone
1108             #
1109             my $declaration = $_->cloneNode(1);
1110             #
1111             # We remove unsupported things
1112             #
1113             $self->_removeEmptyStructDeclaration($declaration);
1114             #
1115             # Recover COMMAs that Marpa's separator hided (and this is normal btw). Our DOM processing relies on the COMMA node.
1116             #
1117             $self->_recoverCommas($declaration);
1118             #
1119             # Enumerators are special: they have no declarator (ok) and can have an initialisation that
1120             # is irrelevant for us (and that would cause trouble in fact)
1121             #
1122             $self->_simplifyEnumerators($declaration);
1123             #
1124             # Ditto for the declarator initializers.
1125             #
1126             $self->_simplifyInitDeclarators($declaration);
1127             #
1128             # We rely on presence of identifiers : insert fake ones wherever needed
1129             #
1130             $self->_addMissingIdentifiers($declaration);
1131             #
1132             # Parse the declaration
1133             #
1134             my $callLevel = -1;
1135             push(@{$self->{_cdecl}}, $self->_topDeclaration2Cdecl($callLevel, $declaration));
1136             }
1137             delete($self->{_cdeclAnonNb});
1138             }
1139             }
1140              
1141             # ----------------------------------------------------------------------------------------
1142              
1143             sub _topDeclaration2Cdecl {
1144             my ($self, $callLevel, $declaration) = @_;
1145              
1146             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_topDeclaration2Cdecl');
1147              
1148             #
1149             # For every declaration we scan all the lexemes, aka nodes that have isLexeme equal to 'true'.
1150             # Other nodes are used to get the context.
1151             #
1152             my $allNodesXpath = $self->_xpath('allNodes.xpath');
1153             my @nodes = $declaration->findnodes($allNodesXpath);
1154              
1155             my $localCdecl = '';
1156             my @cdecl = ();
1157             my @stack = ();
1158             my @declSpecStack = ();
1159              
1160             my $i = 0;
1161             my $last = $self->_readToId($callLevel, \@nodes, \@stack, \$localCdecl, \@declSpecStack);
1162             do {
1163             #
1164             # Every declarator will share the stack up to first (eventually faked) identifier
1165             #
1166             if ($i++ > 0) {
1167             @stack = @declSpecStack;
1168             $last = $self->_readToId($callLevel, \@nodes, \@stack, \$localCdecl);
1169             }
1170             $last = $self->_parseDeclarator($callLevel, \@nodes, \@stack, \$localCdecl, $last);
1171             push(@cdecl, $localCdecl);
1172             $localCdecl = '';
1173              
1174             } while ($last->{node}->localname() eq 'COMMA');
1175              
1176             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_topDeclaration2Cdecl', cdecl => \@cdecl);
1177              
1178             return @cdecl;
1179             }
1180              
1181             sub _logCdecl {
1182             my ($self, $function, %h) = @_;
1183              
1184             #
1185             # Rework case of stack and declSpecStack
1186             #
1187             if (exists($h{stack}) && defined($h{stack})) {
1188             $h{stack} = [ map { $_->{string} } @{$h{stack}} ];
1189             }
1190             if (exists($h{declSpecStack}) && defined($h{declSpecStack})) {
1191             $h{declSpecStack} = [ map { $_->{string} } @{$h{declSpecStack}} ];
1192             }
1193             #
1194             # Rework case of last, next, or previous
1195             #
1196             foreach (qw/previous last next node/) {
1197             if (exists($h{$_})) {
1198             if (exists($h{$_}->{node}) && defined($h{$_}->{node})) {
1199             $h{$_} = {name => $h{$_}->{node}->localname(), isLexeme => $h{$_}->{node}->getAttribute('isLexeme'), text => $h{$_}->{node}->getAttribute('text'), text => $h{$_}->{node}->getAttribute('text'), type => defined($h{$_}->{type}) ? ($type2String[$h{$_}->{type}] || 'UNKNOWN') : undef};
1200             } else {
1201             $h{$_} = undef;
1202             }
1203             }
1204             }
1205             $log->debugf('%s: %s', $function, \%h);
1206             }
1207              
1208             sub _checkPtr {
1209             my ($self, $callLevel, $nodesp, $stackp, $cdeclp) = @_;
1210              
1211             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_checkPtr', stack => $stackp, cdecl => $cdeclp);
1212              
1213             if (! @{$stackp}) {
1214             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_checkPtr', stack => $stackp, cdecl => $cdeclp);
1215             return;
1216             }
1217              
1218             my $t;
1219             for ($t = pop(@{$stackp});
1220             defined($t) && $t->{node}->localname() eq 'STAR';
1221             $t = pop(@{$stackp})) {
1222             ${$cdeclp} .= 'pointer to ';
1223             }
1224             if (defined($t)) {
1225             push(@{$stackp}, $t);
1226             }
1227              
1228             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_checkPtr', stack => $stackp, cdecl => $cdeclp);
1229              
1230             }
1231              
1232             sub _parseDeclarator {
1233             my ($self, $callLevel, $nodesp, $stackp, $cdeclp, $last) = @_;
1234              
1235             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_parseDeclarator', stack => $stackp, cdecl => $cdeclp, last => $last);
1236              
1237             if ($last->{node}->localname() eq 'LBRACKET') {
1238             while ($last->{node}->localname() eq 'LBRACKET') {
1239             $last = $self->_readArraySize($callLevel, $nodesp, $cdeclp);
1240             }
1241             } elsif ($last->{node}->localname() eq 'LPAREN_SCOPE') {
1242             $last = $self->_readFunctionArgs($callLevel, $nodesp, $cdeclp);
1243             } elsif ($last->{node}->localname() eq 'LCURLY') {
1244             if ($last->{node}->parentNode()->localname() eq 'structOrUnionSpecifier') {
1245             $last = $self->_readStructDeclarationList($callLevel, $nodesp, $cdeclp);
1246             }
1247             elsif ($last->{node}->parentNode()->localname() eq 'enumSpecifier') {
1248             $last = $self->_readEnumeratorList($callLevel, $nodesp, $cdeclp);
1249             } else {
1250             croak 'Unsupported parent for LCURLY node: ' . $last->{node}->parentNode()->localname();
1251             }
1252             }
1253             $self->_checkPtr($callLevel, $nodesp, $stackp, $cdeclp);
1254              
1255             while (@{$stackp}) {
1256             my $t = pop(@{$stackp});
1257             if ($t->{node}->localname() eq 'LPAREN') {
1258             $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1259             $last = $self->_parseDeclarator($callLevel + 1, $nodesp, $stackp, $cdeclp, $last); # Recursively parse this ( dcl )
1260             } else {
1261             if ($t->{node}->localname() eq 'TYPEDEF') {
1262             ${$cdeclp} = "Type definition of ${$cdeclp}";
1263             } else {
1264             ${$cdeclp} .= sprintf('%s ', $t->{string});
1265             }
1266             }
1267             }
1268              
1269             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_parseDeclarator', stack => $stackp, cdecl => $cdeclp, last => $last);
1270              
1271             return $last;
1272             }
1273              
1274             sub _readFunctionArgs {
1275             my ($self, $callLevel, $nodesp, $cdeclp) = @_;
1276              
1277             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_readFunctionArgs', cdecl => $cdeclp);
1278              
1279             my $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1280              
1281             if ($last->{node}->localname() eq 'RPAREN_SCOPE') {
1282             ${$cdeclp} .= 'function returning ';
1283             $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1284             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_readFunctionArgs', cdecl => $cdeclp, last => $last);
1285             return $last;
1286             }
1287              
1288             #
1289             # Push back the node
1290             #
1291             unshift(@{$nodesp}, $last->{node});
1292              
1293             ${$cdeclp} .= 'function receiving ';
1294              
1295             my @stack = ();
1296             my $cdecl = '';
1297             do {
1298             #
1299             # Every argument has its own independant stack.
1300             #
1301             $last = $self->_readToId($callLevel, $nodesp, \@stack, \$cdecl);
1302             $last = $self->_parseDeclarator($callLevel, $nodesp, \@stack, \$cdecl, $last);
1303              
1304             if ($last->{node}->localname() eq 'COMMA') {
1305             $cdecl .= ', ';
1306             }
1307             } while ($last->{node}->localname() eq 'COMMA');
1308              
1309             ${$cdeclp} .= '(' . $cdecl . ') and returning ';
1310              
1311             $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1312             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_readFunctionArgs', cdecl => $cdeclp, last => $last);
1313              
1314             return $last;
1315             }
1316              
1317             sub _readStructDeclarationList {
1318             my ($self, $callLevel, $nodesp, $cdeclp) = @_;
1319              
1320             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_readStructDeclarationList', cdecl => $cdeclp);
1321              
1322             ${$cdeclp} .= 'structure defined as ';
1323              
1324             my $localCdecl = '';
1325             my $last;
1326              
1327             do {
1328             my @stack = ();
1329             my @declSpecStack = ();
1330              
1331             $last = $self->_getNode($callLevel, $nodesp, \$localCdecl);
1332             #
1333             # Push back the node
1334             #
1335             unshift(@{$nodesp}, $last->{node});
1336              
1337             if ($last->{node}->localname() ne 'RCURLY') {
1338             my $i;
1339             $last = $self->_readToId($callLevel, $nodesp, \@stack, \$localCdecl, \@declSpecStack);
1340              
1341             do {
1342             #
1343             # Every declarator will share the stack up to first (eventually faked) identifier
1344             #
1345             if ($i++ > 0) {
1346             #
1347             # declarators piling up. Per def they share the same stack, and only the first
1348             # one gets the stack for all the others
1349             #
1350             @stack = @declSpecStack;
1351             $last = $self->_readToId($callLevel, $nodesp, \@stack, \$localCdecl);
1352             }
1353             $last = $self->_parseDeclarator($callLevel, $nodesp, \@stack, \$localCdecl, $last);
1354              
1355             if ($last->{node}->localname() eq 'COMMA') {
1356             $localCdecl .= ', ';
1357             }
1358              
1359             } while ($last->{node}->localname() eq 'COMMA');
1360              
1361             if ($last->{node}->localname() eq 'SEMICOLON') {
1362             $localCdecl .= '; ';
1363             }
1364              
1365             }
1366              
1367             } while ($last->{node}->localname() eq 'SEMICOLON');
1368              
1369             ${$cdeclp} .= '{' . $localCdecl . '}';
1370              
1371             $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1372              
1373             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_readStructDeclarationList', cdecl => $cdeclp, last => $last);
1374              
1375             return $last;
1376             }
1377              
1378             sub _readEnumeratorList {
1379             my ($self, $callLevel, $nodesp, $cdeclp) = @_;
1380             #
1381             # This is very similar to _readFunctionArgs()
1382             #
1383             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_readEnumeratorList', cdecl => $cdeclp);
1384             #
1385             # Empty enumeratorList is not allowed. No need to pre-read the next node.
1386             #
1387             ${$cdeclp} .= 'enumeration defined as ';
1388              
1389             my @stack = ();
1390             my $cdecl = '';
1391             my $last;
1392             do {
1393             #
1394             # Every argument has its own stack (which contains only the identifier -;)
1395             #
1396             $last = $self->_readToId($callLevel, $nodesp, \@stack, \$cdecl);
1397             #
1398             # There is no declarator, really - we fake one.
1399             #
1400             $cdecl .= $self->{_enumType};
1401              
1402             if ($last->{node}->localname() eq 'COMMA') {
1403             $cdecl .= ', ';
1404             }
1405              
1406             } while ($last->{node}->localname() eq 'COMMA');
1407              
1408             ${$cdeclp} .= '{' . $cdecl . '} ';
1409              
1410             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_readEnumeratorList', cdecl => $cdeclp, last => $last);
1411              
1412             return $last;
1413             }
1414              
1415             sub _readArraySize {
1416             my ($self, $callLevel, $nodesp, $cdeclp) = @_;
1417              
1418             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_readArraySize', cdecl => $cdeclp);
1419              
1420             #
1421             # Per def next node in the list is the one just after LBRACKET
1422             #
1423             my $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1424             my $start = $last->{node}->getAttribute('start');
1425             my $end = 0;
1426              
1427             while ($last->{node}->localname() ne 'RBRACKET') {
1428             $end = $last->{node}->getAttribute('start') + $last->{node}->getAttribute('length');
1429             $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1430             }
1431             my $size = '';
1432             if ($end > 0) {
1433             ${$cdeclp} .= sprintf('array[%s] of ', substr($self->{_stdout_buf}, $start, $end - $start));
1434             } else {
1435             ${$cdeclp} .= sprintf('array[] of ');
1436             }
1437              
1438             $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1439              
1440             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_readArraySize', cdecl => $cdeclp, last => $last);
1441              
1442             return $last;
1443             }
1444              
1445             sub _readToId {
1446             my ($self, $callLevel, $nodesp, $stackp, $cdeclp, $declSpecStackp) = @_;
1447              
1448             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_readToId', stack => $stackp, cdecl => $cdeclp, declSpecStack => $declSpecStackp);
1449              
1450             my $last;
1451              
1452             #
1453             # _readToId() has a special mode when we want to distinguish the presence of declarator
1454             # inside the stack. This is needed in cases of:
1455             # * top level declarations
1456             # * structure declaration lists
1457             # because, in this case, multiple declarators can share the same declaration specifiers, e.g.:
1458             # float x,y
1459             #
1460             # This is not needed in case of enumeration lists, not function arguments, because in these later
1461             # cases, no identifier is sharing a declaration specifier stack, e.g.:
1462             # f(float x, float y)
1463             # f(float, float)
1464             # enum {A, B}
1465             #
1466             if (defined($declSpecStackp)) {
1467             for ($last = $self->_getNode($callLevel, $nodesp, $cdeclp, 1);
1468              
1469             $last->{type} != IDENTIFIER && $last->{type} != DECLARATOR;
1470              
1471             do {
1472             if ($last->{type} != DECLARATOR) {
1473             push(@{$stackp}, $last);
1474             $self->_logCdecl('[-]' . (' ' x $callLevel) . '_readToId: pushed to stack', stack => $stackp);
1475             push(@{$declSpecStackp}, $last);
1476             $self->_logCdecl('[-]' . (' ' x $callLevel) . '_readToId: pushed to declaration specifiers stack', declSpecStack => $declSpecStackp);
1477             $last = $self->_getNode($callLevel, $nodesp, $cdeclp, 1);
1478             }
1479             }) {}
1480             }
1481             if (! defined($declSpecStackp) || $last->{type} == DECLARATOR) {
1482             for ($last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1483              
1484             $last->{type} != IDENTIFIER;
1485              
1486             push(@{$stackp}, $last),
1487             $self->_logCdecl('[-]' . (' ' x $callLevel) . '_readToId: pushed to stack', stack => $stackp),
1488             $last = $self->_getNode($callLevel, $nodesp, $cdeclp)) {}
1489             }
1490              
1491             #
1492             # Subtility with ELLIPSIS, per def there is no declaration at all
1493             #
1494             if ($last->{node}->localname() eq 'ELLIPSIS') {
1495             ${$cdeclp} .= sprintf('%s ', $last->{string});
1496             } else {
1497             ${$cdeclp} .= sprintf('%s: ', $last->{string});
1498             }
1499              
1500             $last = $self->_getNode($callLevel, $nodesp, $cdeclp);
1501              
1502             $self->_logCdecl('[<]' . (' ' x $callLevel--) .'_readToId', stack => $stackp, declSpecStack => $declSpecStackp, cdecl => $cdeclp, last => $last);
1503              
1504             return $last;
1505             }
1506              
1507             sub _classifyNode {
1508             my ($self, $callLevel, $node, $nodesp, $cdeclp, $detectDeclarator) = @_;
1509              
1510             $detectDeclarator //= 0;
1511              
1512             my $previous = $node->previousSibling();
1513             my $last = {node => $node,
1514             string => undef,
1515             type => undef};
1516             my $next = $node->nextSibling();
1517              
1518             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_classifyNode', cdecl => $cdeclp, last => $last, detectDeclarator => $detectDeclarator);
1519              
1520             my $name = $node->localname();
1521             my $firstChild = $node->firstChild();
1522             my $isLexeme = $last->{node}->getAttribute('isLexeme') || 'false';
1523              
1524             if ($name eq 'CONST') { # We call const "read-only" to clarify
1525             $last->{string} = 'read-only';
1526             } elsif ($name eq 'ELLIPSIS') { # We call ... "etc."
1527             $last->{string} = 'etc.';
1528             } else {
1529             $last->{string} = $last->{node}->getAttribute('text');
1530             }
1531              
1532             my $parent = $last->{node}->parentNode();
1533             my $parentName = $parent->localname();
1534              
1535             if ($name eq 'declarator' && $detectDeclarator) {
1536             $last->{type} = DECLARATOR;
1537             }
1538             elsif ($name eq 'IDENTIFIER' || $name eq 'IDENTIFIER_UNAMBIGUOUS' || $name eq 'ANON_IDENTIFIER' || $name eq 'ELLIPSIS') {
1539             $last->{type} = IDENTIFIER;
1540             }
1541             elsif ($parentName eq 'typeQualifier') {
1542             $last->{type} = QUALIFIER;
1543             }
1544             #
1545             # Case of embedded definitions within declarations
1546             #
1547             elsif ($name eq 'structOrUnionSpecifier') {
1548             #
1549             # Remember that we guaranteed to have inserted a fake identifier if there is none, i.e.
1550             # the rule is:
1551             #
1552             # structOrUnionSpecifier
1553             # ::= structOrUnion ANON_IDENTIFIER LCURLY structDeclarationList RCURLY
1554             # | structOrUnion IDENTIFIER_UNAMBIGUOUS LCURLY structDeclarationList RCURLY
1555             # | structOrUnion IDENTIFIER_UNAMBIGUOUS
1556             #
1557             if (defined($firstChild->nextSibling()->nextSibling())) {
1558             #
1559             # The test on the third child is necessary because of recursive calls to this routine
1560             #
1561             my $structOrUnion = $firstChild;
1562             my $IDENTIFIER = $structOrUnion->nextSibling();
1563             my $LCURLY = $IDENTIFIER->nextSibling();
1564             my $structDeclarationList = $LCURLY->nextSibling();
1565             my $RCURLY = $structDeclarationList->nextSibling();
1566             #
1567             # Get a verbose string for this structure definition.
1568             # Even if _topDeclaration can return more than one value, per def for a
1569             # structOrUnionSpecifier it will return a single element.
1570             #
1571             $last->{string} = ($self->_topDeclaration2Cdecl($callLevel, $node->cloneNode(1)))[0];
1572             $node->setAttribute('text', $last->{string});
1573             #
1574             # Eat all nodes until /this/ RCURLY
1575             #
1576             my $startRcurly=$RCURLY->getAttribute('start');
1577             my $nextStart;
1578             do {
1579             my $nextNode = shift(@{$nodesp});
1580             $self->_logCdecl('[-]' . (' ' x $callLevel) . '_classifyNode: pass-through', node => {node => $nextNode});
1581             $nextStart = defined($nextNode) ? ($nextNode->getAttribute('start') || -1) : -1;
1582             } while ($nextStart != $startRcurly);
1583             #
1584             # We remove also children from LCURLY up to RCURLY
1585             #
1586             $node->removeChild($LCURLY);
1587             $node->removeChild($structDeclarationList);
1588             $node->removeChild($RCURLY);
1589             }
1590             #
1591             # Say that current node, a 'structOrUnionSpecifier' is a type (and it is)
1592             #
1593             $last->{type} = TYPE;
1594             }
1595             #
1596             # We do not want to the words 'struct' or 'union' to appear: full decl is in the return value of the embedded call to _topDeclaration2Cdecl() upper
1597             #
1598             elsif ($name eq 'STRUCT' || $name eq 'UNION') {
1599             $last->{type} = SKIPPED;
1600             }
1601             elsif ($name eq 'enumSpecifier') {
1602             #
1603             # Remember (bis) that we guaranteed to have inserted a fake identifier if there is none, i.e.
1604             # the rule is:
1605             #
1606             # enumSpecifier
1607             # ::= ENUM ANON_IDENTIFIER LCURLY enumeratorList RCURLY
1608             # | ENUM IDENTIFIER_UNAMBIGUOUS LCURLY enumeratorList RCURLY
1609             # | ENUM IDENTIFIER_UNAMBIGUOUS
1610             #
1611             if (defined($firstChild->nextSibling()->nextSibling())) {
1612             #
1613             # The test on the third child is necessary because of recursive calls to this routine
1614             #
1615             my $ENUM = $firstChild;
1616             my $IDENTIFIER = $ENUM->nextSibling();
1617             my $LCURLY = $IDENTIFIER->nextSibling();
1618             my $enumeratorList = $LCURLY->nextSibling();
1619             my $RCURLY = $enumeratorList->nextSibling();
1620             #
1621             # Get a verbose string for this enum definition
1622             # Even if _topDeclaration can return more than one value, per def for an
1623             # enumSpecifier it will return a single element.
1624             #
1625             $last->{string} = ($self->_topDeclaration2Cdecl($callLevel, $node->cloneNode(1)))[0];
1626             $node->setAttribute('text', $last->{string});
1627             #
1628             # Eat all nodes until /this/ RCURLY
1629             #
1630             my $startRcurly=$RCURLY->getAttribute('start');
1631             my $nextStart;
1632             do {
1633             my $nextNode = shift(@{$nodesp});
1634             $self->_logCdecl('[-]' . (' ' x $callLevel) . '_classifyNode: pass-through', node => {node => $nextNode});
1635             $nextStart = defined($nextNode) ? ($nextNode->getAttribute('start') || -1) : -1;
1636             } while ($nextStart != $startRcurly);
1637             #
1638             # We remove also children from LCURLY up to RCURLY
1639             #
1640             $node->removeChild($LCURLY);
1641             $node->removeChild($enumeratorList);
1642             $node->removeChild($RCURLY);
1643             }
1644             #
1645             # Say that current node, a 'enumSpecifier' is a type (and it is)
1646             #
1647             $last->{type} = TYPE;
1648             }
1649             #
1650             # We do not want to the word 'enum' to appear: full decl is in the return value of the embedded call to _topDeclaration2Cdecl() upper
1651             #
1652             elsif ($name eq 'ENUM') {
1653             $last->{type} = SKIPPED;
1654             }
1655             elsif ($parentName eq 'typeSpecifier1' ||
1656             $parentName eq 'typeSpecifier2' ||
1657             $parentName eq 'atomicTypeSpecifier' ||
1658             $parentName eq 'msvsBuiltinType' ||
1659             $parentName eq 'gccBuiltinType' ||
1660             $parentName eq 'gccTypeof') {
1661             $last->{type} = TYPE;
1662             }
1663             elsif ($isLexeme eq 'true') {
1664             $last->{type} = OTHER;
1665             if ($name eq 'STAR') {
1666             # Make string contain "pointer to", otherwise, qualified pointers would be printed as '*'
1667             $last->{string} = 'pointer to';
1668             }
1669             } else {
1670             $last->{type} = SKIPPED;
1671             }
1672              
1673             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_classifyNode', cdecl => $cdeclp, detectDeclarator => $detectDeclarator, last => $last);
1674              
1675             return $last;
1676             }
1677              
1678             sub _getNode {
1679             my ($self, $callLevel, $nodesp, $cdeclp, $detectDeclarator) = @_;
1680              
1681             $detectDeclarator //= 0;
1682              
1683             $self->_logCdecl('[>]' . (' ' x ++$callLevel) . '_getNode', cdecl => $cdeclp, detectDeclarator => $detectDeclarator);
1684              
1685             my $node;
1686             my $last;
1687             do {
1688             $node = shift(@{$nodesp});
1689             if (! defined($node)) {
1690             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_getNode', cdecl => $cdeclp, detectDeclarator => $detectDeclarator, last => undef);
1691             return;
1692             }
1693             $last = $self->_classifyNode($callLevel, $node, $nodesp, $cdeclp, $detectDeclarator);
1694             } while ($last->{type} == SKIPPED);
1695              
1696             $self->_logCdecl('[<]' . (' ' x $callLevel--) . '_getNode', cdecl => , $cdeclp, detectDeclarator => $detectDeclarator, last => $last, string => $last->{string});
1697              
1698             return $last;
1699             }
1700              
1701             # ----------------------------------------------------------------------------------------
1702              
1703             sub _typedef_hash {
1704             my ($self) = @_;
1705              
1706             if (! defined($self->{_typedef_hash})) {
1707             $self->{_typedef_hash} = $self->{_asDOM} ? XML::LibXML::Document->new() : {};
1708             $self->{_typedef_texts} = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
1709             $self->{_typedefs_maybe} = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
1710             $self->{_typedef_structs} = $self->{_asDOM} ? XML::LibXML::Document->new() : {};
1711             #
1712             # typedef is a "declaration" node
1713             #
1714             foreach my $declaration ($self->ast()->findnodes($self->_xpath('typedef.xpath'))) {
1715             my $file;
1716             if (! $self->_pushNodeFile(\$file, $declaration)) {
1717             next;
1718             }
1719              
1720             my @declarationSpecifiers = $declaration->findnodes($self->_xpath('firstDeclarationSpecifiers.xpath'));
1721             if (! @declarationSpecifiers) {
1722             #
1723             # Could be a static assert declaration
1724             #
1725             next;
1726             }
1727             my $text;
1728             my $declarationSpecifiers;
1729             $self->_pushNodeString(\$text, $declaration);
1730             $self->_pushNodeString(\$declarationSpecifiers, $declarationSpecifiers[0]);
1731             #
1732             # typedef_texts does not have the typedef keyword, neither what will contain typedef_hash
1733             #
1734             $self->_removeWord(\$text, 'typedef');
1735             $self->_removeWord(\$declarationSpecifiers, 'typedef');
1736             if ($self->{_asDOM}) {
1737             my $child = XML::LibXML::Element->new('typedef');
1738             $child->setAttribute('text', $text);
1739             $child->setAttribute('file', $file);
1740             $self->{_typedef_texts}->addChild($child);
1741             } else {
1742             push(@{$self->{_typedef_texts}}, $text);
1743             }
1744             #
1745             # typedef name
1746             #
1747             my @declarator = $declaration->findnodes($self->_xpath('declaration2Declarator.xpath'));
1748             my @keys = ();
1749             my @before = ();
1750             my @after = ();
1751             foreach (@declarator) {
1752             my $declarator;
1753             $self->_pushNodeString(\$declarator, $_);
1754              
1755             my @IDENTIFIER = $_->findnodes($self->_xpath('declarator2IDENTIFIER.xpath'));
1756             $self->_pushNodeString(\@keys, $IDENTIFIER[0]);
1757             $declarator =~ /(.*)$keys[-1](.*)/;
1758             my $before = defined($-[1]) ? substr($declarator, $-[1], $+[1]-$-[1]) : '';
1759             my $after = defined($-[2]) ? substr($declarator, $-[2], $+[2]-$-[2]) : '';
1760             push(@before, ($before =~ /[^\s]/) ? ' ' . $before : '');
1761             push(@after, ($after =~ /[^\s]/) ? ' ' . $after : '');
1762             }
1763             if (! @keys) {
1764             push(@keys, sprintf('ANON%d', $self->{_anonCount}++));
1765             push(@before, '');
1766             push(@after, '');
1767             }
1768             if ($self->{_asDOM}) {
1769             foreach (@keys) {
1770             my $child = XML::LibXML::Element->new('typedef');
1771             $child->setAttribute('id', $_);
1772             $child->setAttribute('file', $file);
1773             $self->{_typedefs_maybe}->addChild($child);
1774             }
1775             } else {
1776             push(@{$self->{_typedefs_maybe}}, @keys);
1777             }
1778             foreach (0..$#keys) {
1779             #
1780             # typedef before/after
1781             #
1782             if ($self->{_asDOM}) {
1783             my $child = XML::LibXML::Element->new('typedef');
1784             $child->setAttribute('id', $keys[$_]);
1785             $child->setAttribute('before', $declarationSpecifiers . $before[$_]);
1786             $child->setAttribute('after', $after[$_]);
1787             $child->setAttribute('file', $file);
1788             $self->{_typedef_hash}->addChild($child);
1789             } else {
1790             $self->{_typedef_hash}->{$keys[$_]} = [ $declarationSpecifiers . $before[$_], $after[$_] ];
1791             }
1792             }
1793             #
1794             # Is a struct or union declaration ?
1795             #
1796             my @structOrUnionSpecifier = $declarationSpecifiers[0]->findnodes($self->_xpath('declarationSpecifiers2structOrUnionSpecifier.xpath'));
1797             if (@structOrUnionSpecifier) {
1798             my $struct = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
1799             my $declsDOM = undef;
1800              
1801             my @structDeclaration = $structOrUnionSpecifier[0]->findnodes($self->_xpath('structOrUnionSpecifier2structDeclaration.xpath'));
1802             foreach (@structDeclaration) {
1803              
1804             my @specifierQualifierList = $_->findnodes($self->_xpath('structDeclaration2specifierQualifierList.xpath'));
1805             if (! @specifierQualifierList) {
1806             # Gcc extension
1807             next;
1808             }
1809             my $specifierQualifierList;
1810             $self->_pushNodeString(\$specifierQualifierList, $specifierQualifierList[0]);
1811              
1812             my @structDeclarator = $_->findnodes($self->_xpath('structDeclaration2structDeclarator.xpath'));
1813             my @keys = ();
1814             my @before = ();
1815             my @after = ();
1816             foreach (@structDeclarator) {
1817             my $structDeclarator;
1818             $self->_pushNodeString(\$structDeclarator, $_);
1819              
1820             my @IDENTIFIER = $_->findnodes($self->_xpath('structDeclarator2IDENTIFIER.xpath'));
1821             if (@IDENTIFIER) {
1822             $self->_pushNodeString(\@keys, $IDENTIFIER[0]);
1823             } else {
1824             # COLON constantExpression
1825             push(@keys, sprintf('ANON%d', $self->{_anonCount}++));
1826             }
1827             $structDeclarator =~ /(.*)$keys[-1](.*)/;
1828              
1829             my $before = defined($-[1]) ? substr($structDeclarator, $-[1], $+[1]-$-[1]) : '';
1830             my $after = defined($-[2]) ? substr($structDeclarator, $-[2], $+[2]-$-[2]) : '';
1831             push(@before, $specifierQualifierList . (($before =~ /[^\s]/) ? ' ' . $before : ''));
1832             push(@after, $after);
1833             }
1834             if (! @keys) {
1835             push(@keys, sprintf('ANON%d', $self->{_anonCount}++));
1836             push(@before, '');
1837             push(@after, '');
1838             }
1839             foreach (0..$#keys) {
1840             #
1841             # structDeclarator before/after
1842             #
1843             if ($self->{_asDOM}) {
1844             my $child = XML::LibXML::Element->new('decl');
1845             $child->setAttribute('id', $keys[$_]);
1846             $child->setAttribute('before', $before[$_]);
1847             $child->setAttribute('after', $after[$_]);
1848             $child->setAttribute('file', $file);
1849             if (! defined($declsDOM)) {
1850             $declsDOM = XML::LibXML::Element->new('decls');
1851             $struct->addChild($declsDOM);
1852             }
1853             $declsDOM->addChild($child);
1854             } else {
1855             push(@{$struct}, [ $before[$_], $after[$_], $keys[$_] ]);
1856             }
1857             }
1858             }
1859             foreach (0..$#keys) {
1860             #
1861             # typedef before/after
1862             #
1863             if ($self->{_asDOM}) {
1864             my $child = XML::LibXML::Element->new('struct');
1865             $child->setAttribute('id', $keys[$_]);
1866             $child->setAttribute('file', $file);
1867             $child->setAttribute('structOrUnion', 'true');
1868             $self->{_typedef_structs}->addChild($child);
1869             foreach ($struct->childNodes()) {
1870             my $newnode = $_->cloneNode(1);
1871             $child->addChild($newnode);
1872             }
1873             } else {
1874             $self->{_typedef_structs}->{$keys[$_]} = $struct;
1875             }
1876             }
1877             } else {
1878             foreach (0..$#keys) {
1879             #
1880             # Not a struct nor union
1881             #
1882             if ($self->{_asDOM}) {
1883             my $child = XML::LibXML::Element->new('struct');
1884             $child->setAttribute('id', $keys[$_]);
1885             $child->setAttribute('file', $file);
1886             $child->setAttribute('structOrUnion', 'false');
1887             $self->{_typedef_structs}->addChild($child);
1888             } else {
1889             $self->{_typedef_structs}->{$keys[$_]} = undef;
1890             }
1891             }
1892             }
1893             }
1894             }
1895              
1896             return $self->{_typedef_hash};
1897             }
1898              
1899             # ----------------------------------------------------------------------------------------
1900              
1901             sub _parsed_fdecls {
1902             my ($self) = @_;
1903              
1904             if (! defined($self->{_parsed_fdecls})) {
1905             $self->{_parsed_fdecls} = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
1906             $self->{_fdecls} = $self->{_asDOM} ? XML::LibXML::Element->new('fdecls') : [];
1907              
1908             foreach my $node ($self->ast()->findnodes($self->_xpath('fdecls.xpath'))) {
1909             my $file = '';
1910             if (! $self->_pushNodeFile(\$file, $node)) {
1911             next;
1912             }
1913              
1914             my $fdecl = [];
1915             #
1916             # rt
1917             #
1918             my @declarationSpecifiers = $node->findnodes($self->_xpath('firstDeclarationSpecifiers.xpath'));
1919             if (! @declarationSpecifiers) {
1920             #
1921             # Could be a static assert declaration
1922             #
1923             next;
1924             }
1925             $self->_pushNodeString($fdecl, $declarationSpecifiers[0]);
1926             #
1927             # Remove eventual typedef
1928             #
1929             $self->_removeWord(\$fdecl->[-1], 'typedef');
1930             #
1931             # nm. In case of a function declaration, there can be only a single declarator
1932             # in the declaration
1933             #
1934             my @declarator = $node->findnodes($self->_xpath('declaration2Declarator.xpath'));
1935             if (! @declarator) {
1936             my $anon = sprintf('ANON%d', $self->{_anonCount}++);
1937             push(@{$fdecl}, $anon);
1938             } else {
1939             my @IDENTIFIER = $declarator[0]->findnodes($self->_xpath('declarator2IDENTIFIER.xpath'));
1940             if (! @IDENTIFIER) {
1941             my $anon = sprintf('ANON%d', $self->{_anonCount}++);
1942             push(@{$fdecl}, $anon);
1943             } else {
1944             $self->_pushNodeString($fdecl, $IDENTIFIER[0]);
1945             }
1946             }
1947             #
1948             # args
1949             #
1950             my $args = $self->{_asDOM} ? XML::LibXML::Element->new('args') : [];
1951             my @args = $node->findnodes($self->_xpath('fdecl2args.xpath'));
1952             foreach (@args) {
1953             #
1954             # arg is a parameterDeclaration
1955             #
1956             my $arg = [];
1957             #
1958             # arg.rt
1959             #
1960             my @declarationSpecifiers = $_->findnodes($self->_xpath('firstDeclarationSpecifiers.xpath'));
1961             $self->_pushNodeString($arg, $declarationSpecifiers[0]);
1962             #
1963             # arg.nm or ANON
1964             #
1965             my $anon = undef;
1966             my @nm = $_->findnodes($self->_xpath('arg2nm.xpath'));
1967             if (@nm) {
1968             $self->_pushNodeString($arg, $nm[0]);
1969             } else {
1970             my $anon = sprintf('ANON%d', $self->{_anonCount}++);
1971             push(@{$arg}, $anon);
1972             }
1973             #
1974             # arg.arg is always undef
1975             #
1976             push(@{$arg}, undef);
1977             #
1978             # arg.ft
1979             #
1980             $self->_pushNodeString($arg, $_);
1981             if ($anon) {
1982             #
1983             # We faked an anonymous identifier
1984             #
1985             $arg->[-1] .= ' ' . $anon;
1986             }
1987             #
1988             # arg.mod
1989             #
1990             my @mod = $_->findnodes($self->_xpath('arg2mod.xpath'));
1991             if (@mod) {
1992             #
1993             # Per def $mod[0] is a directDeclarator that can be:
1994             #
1995             # directDeclarator LBRACKET RBRACKET
1996             # directDeclarator LBRACKET STAR RBRACKET
1997             # directDeclarator LBRACKET STATIC gccArrayTypeModifierList assignmentExpression RBRACKET
1998             # etc...
1999             #
2000             # We clone the node, remove the first child. What remains will be the array modifiers.
2001             #
2002             my $newnode = $mod[0]->cloneNode(1);
2003             my $childnode = $newnode->firstChild;
2004             $newnode->removeChild($childnode );
2005             $self->_pushNodeString($arg, $newnode);
2006             } else {
2007             push(@{$arg}, '');
2008             }
2009             if ($self->{_asDOM}) {
2010             my $child = XML::LibXML::Element->new('arg');
2011             $child->setAttribute('type', $arg->[0]);
2012             $child->setAttribute('id', $arg->[1]);
2013             #
2014             # Undef per construction, i.e. we do not put this attribute
2015             #
2016             # $child->setAttribute('args', $arg->[2]);
2017             $child->setAttribute('text', $arg->[3]);
2018             $child->setAttribute('mod', $arg->[4]);
2019             $args->addChild($child);
2020             } else {
2021             push(@{$args}, $arg);
2022             }
2023             }
2024             push(@{$fdecl}, $args);
2025             #
2026             # ft, without remaining semicolon
2027             #
2028             $self->_pushNodeString($fdecl, $node);
2029             $fdecl->[-1] =~ s/\s*;$//;
2030             #
2031             # mod is always undef
2032             #
2033             push(@{$fdecl}, undef);
2034              
2035             if ($self->{_asDOM}) {
2036             my $child = XML::LibXML::Element->new('fdecl');
2037             $child->setAttribute('type', $fdecl->[0]);
2038             $child->setAttribute('id', $fdecl->[1]);
2039             $child->addChild($fdecl->[2]);
2040             $child->setAttribute('text', $fdecl->[3]);
2041             $child->setAttribute('file', $file);
2042             #
2043             # Undef per construction: we do not include this attribute
2044             #
2045             # $child->setAttribute('mod', $fdecl->[4]);
2046             $self->{_parsed_fdecls}->addChild($child);
2047             } else {
2048             push(@{$self->{_parsed_fdecls}}, $fdecl);
2049             }
2050              
2051             if ($self->{_asDOM}) {
2052             my $child = XML::LibXML::Element->new('fdecl');
2053             $child->setAttribute('id', $fdecl->[1]);
2054             $child->setAttribute('text', $fdecl->[3]);
2055             $child->setAttribute('file', $file);
2056             $self->{_fdecls}->addChild($child);
2057             } else {
2058             push(@{$self->{_fdecls}}, $fdecl->[3]);
2059             }
2060             }
2061             }
2062              
2063             return $self->{_parsed_fdecls};
2064             }
2065              
2066             # ----------------------------------------------------------------------------------------
2067              
2068             sub _inlines {
2069             my ($self) = @_;
2070              
2071             if (! defined($self->{_inlines})) {
2072             $self->{_inlines} = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
2073             #
2074             # Simply, any path matching functionDefinition
2075             #
2076             foreach ($self->ast()->findnodes($self->_xpath('inlines.xpath'))) {
2077             my $file = '';
2078             if (! $self->_pushNodeFile(\$file, $_)) {
2079             next;
2080             }
2081             my $text = '';
2082             $self->_pushNodeString(\$text, $_);
2083             if ($self->{_asDOM}) {
2084             my $child = XML::LibXML::Element->new('inline');
2085             $child->setAttribute('text', $text);
2086             $child->setAttribute('file', $file);
2087             $self->{_inlines}->addChild($child);
2088             } else {
2089             push(@{$self->{_inlines}}, $text);
2090             }
2091             }
2092             }
2093              
2094             return $self->{_inlines};
2095             }
2096              
2097             # ----------------------------------------------------------------------------------------
2098              
2099             sub _lexemeCallback {
2100             my ($lexemeCallbackHashp, $lexemeHashp) = @_;
2101              
2102             my $self = $lexemeCallbackHashp->{self};
2103             my $tmpHashp = $lexemeCallbackHashp->{tmpHashp};
2104              
2105             #
2106             # We wait until the first #line information: this will give the name of current file
2107             #
2108             if ($lexemeHashp->{name} eq 'PREPROCESSOR_LINE_DIRECTIVE') {
2109             if ($lexemeHashp->{value} =~ /([\d]+)\s*\"([^\"]+)\"/) {
2110             my $currentFile = File::Spec->canonpath(substr($lexemeHashp->{value}, $-[2], $+[2] - $-[2]));
2111             if (! defined($self->{_filename})) {
2112             #
2113             # The very first filename is always the original source.
2114             #
2115             $self->{_filename} = $currentFile;
2116             }
2117              
2118             $tmpHashp->{_currentFile} = $currentFile;
2119             $tmpHashp->{_includes}->{$currentFile} = 1;
2120              
2121             $self->{_position2File}->{$lexemeHashp->{start}} = $currentFile;
2122              
2123             }
2124             #
2125             # This is an internal lexeme, no problem to change a bit the value. For instance, remove
2126             # \s if any.
2127             #
2128             $lexemeHashp->{value} =~ s/^\s*//g;
2129             $lexemeHashp->{value} =~ s/\s*$//g;
2130             $lexemeHashp->{value} =~ s/\n/\\n/g;
2131             }
2132              
2133             if (defined($tmpHashp->{_currentFile}) && $self->_fileOk($tmpHashp->{_currentFile})) {
2134             if ($lexemeHashp->{name} eq 'STRING_LITERAL_UNIT') {
2135             #
2136             # ISO C permits WS at the end of a string literal, we remove it
2137             #
2138             my $string = $lexemeHashp->{value};
2139             $string =~ s/[ \t\v\n\f]*$//;
2140             if ($self->{_asDOM}) {
2141             my $child = XML::LibXML::Element->new('string');
2142             $child->setAttribute('text', $string);
2143             $child->setAttribute('file', $tmpHashp->{_currentFile});
2144             $self->{_strings}->addChild($child)
2145             } else {
2146             push(@{$self->{_strings}}, $string);
2147             }
2148             }
2149             }
2150             }
2151              
2152             # ----------------------------------------------------------------------------------------
2153              
2154             sub _analyse_with_heuristics {
2155             my ($self) = @_;
2156              
2157             if (! defined($self->{_content})) {
2158             #
2159             # Case where it was a filename given.
2160             # Per-def $self->{_tmpfh} is at the beginning of file at this time
2161             #
2162             $self->{_content} = do {my $fh = $self->{_tmpfh}; local $/; <$fh>;};
2163             }
2164              
2165             $self->{_macros} = $self->{_asDOM} ? XML::LibXML::Document->new() : [];
2166             pos($self->{_content}) = undef;
2167             while ($self->{_content} =~ m/$REDEFINE/g) {
2168             my $text = substr($self->{_content}, $-[1], $+[1] - $-[1]);
2169             my $id = substr($self->{_content}, $-[2], $+[2] - $-[2]);
2170             my $file = $self->_position2File($-[0]);
2171             if ($self->{_asDOM}) {
2172             my $child = XML::LibXML::Element->new('macro');
2173             $child->setAttribute('text', $text);
2174             $child->setAttribute('id', $id);
2175             $child->setAttribute('file', $file);
2176             $self->{_macros}->addChild($child);
2177             } else {
2178             push(@{$self->{_macros}}, [ $text, $id, $file ]);
2179             }
2180             }
2181             }
2182              
2183             # ----------------------------------------------------------------------------------------
2184              
2185             sub _posprocess_heuristics {
2186             my ($self) = @_;
2187              
2188             #
2189             # We want to have defines_args and defines_no_args
2190             #
2191             $self->{_defines_args} = $self->{_asDOM} ? XML::LibXML::Document->new() : {};
2192             $self->{_defines_no_args} = $self->{_asDOM} ? XML::LibXML::Document->new() : {};
2193             foreach ($self->{_asDOM} ? $self->macros->childNodes() : @{$self->macros}) {
2194             my $text = $self->{_asDOM} ? $_->getAttribute('text') : $_->[0];
2195             my $id = $self->{_asDOM} ? $_->getAttribute('id') : $_->[1];
2196             my $file = $self->{_asDOM} ? $_->getAttribute('file') : $_->[2];
2197             if ($text =~ /^(\w+)\s*$BALANCEDPARENS\s*(.*)/s) {
2198             my $args = substr($text, $-[2], $+[2] - $-[2]);
2199             my $value = substr($text, $-[3], $+[3] - $-[3]);
2200             substr($args, 0, 1, ''); # '('
2201             substr($args, -1, 1, ''); # ')'
2202             my @args = map {my $element = $_; $element =~ s/\s//g; $element;} split(/,/, $args);
2203             if ($self->{_asDOM}) {
2204             my $child = XML::LibXML::Element->new('define');
2205             $child->setAttribute('text', $text);
2206             $child->setAttribute('id', $id);
2207             $child->setAttribute('file', $file);
2208             $child->setAttribute('value', $value);
2209              
2210             my $subchild = XML::LibXML::Element->new('args');
2211             foreach (@args) {
2212             $subchild->addChild(XML::LibXML::Element->new('arg'))->setAttribute('id', $_);
2213             }
2214             $child->addChild($subchild);
2215              
2216             $self->{_defines_args}->addChild($child);
2217             } else {
2218             $self->{_defines_args}->{$id} = [ $text, [ @args ], $value, $file ];
2219             }
2220             } elsif ($text =~ /(\w+)\s*(.*)/s) {
2221             my $value = substr($text, $-[2], $+[2] - $-[2]);
2222             if ($self->{_asDOM}) {
2223             my $child = XML::LibXML::Element->new('define');
2224             $child->setAttribute('text', $text);
2225             $child->setAttribute('id', $id);
2226             $child->setAttribute('file', $file);
2227             $child->setAttribute('value', $value);
2228             $self->{_defines_no_args}->addChild($child);
2229             } else {
2230             $self->{_defines_no_args}->{$id} = [ $text, $value, $file ];
2231             }
2232             }
2233             }
2234             }
2235              
2236             # ----------------------------------------------------------------------------------------
2237              
2238              
2239             sub c2cifce {
2240             my ($self, $lang, %params) = @_;
2241              
2242             $log->tracef('Calling transformation with parameters %s', \%params);
2243              
2244             my $ast = $self->ast();
2245             my $langXslt = $self->_xslt($lang);
2246             my $transform = $langXslt->transform($ast, %params);
2247              
2248             return ($langXslt, $transform);
2249             }
2250              
2251             # ----------------------------------------------------------------------------------------
2252              
2253              
2254             1;
2255              
2256             __END__