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