1#
2# KDOM IDL parser
3#
4# Copyright (C) 2005 Nikolas Zimmermann <wildfox@kde.org>
5#
6# This library is free software; you can redistribute it and/or
7# modify it under the terms of the GNU Library General Public
8# License as published by the Free Software Foundation; either
9# version 2 of the License, or (at your option) any later version.
10#
11# This library is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14# Library General Public License for more details.
15#
16# You should have received a copy of the GNU Library General Public License
17# along with this library; see the file COPYING.LIB.  If not, write to
18# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
19# Boston, MA 02110-1301, USA.
20#
21
22package IDLParser;
23
24use strict;
25
26use IPC::Open2;
27use IDLStructure;
28
29use constant MODE_UNDEF    => 0; # Default mode.
30
31use constant MODE_MODULE  => 10; # 'module' section
32use constant MODE_INTERFACE  => 11; # 'interface' section
33use constant MODE_EXCEPTION  => 12; # 'exception' section
34use constant MODE_ALIAS    => 13; # 'alias' section
35
36# Helper variables
37my @temporaryContent = "";
38
39my $parseMode = MODE_UNDEF;
40my $preservedParseMode = MODE_UNDEF;
41
42my $beQuiet; # Should not display anything on STDOUT?
43my $document = 0; # Will hold the resulting 'idlDocument'
44my $parentsOnly = 0; # If 1, parse only enough to populate parents list
45
46# Default Constructor
47sub new
48{
49    my $object = shift;
50    my $reference = { };
51
52    $document = 0;
53    $beQuiet = shift;
54
55    bless($reference, $object);
56    return $reference;
57}
58
59# Returns the parsed 'idlDocument'
60sub Parse
61{
62    my $object = shift;
63    my $fileName = shift;
64    my $defines = shift;
65    my $preprocessor = shift;
66    $parentsOnly = shift;
67
68    if (!$preprocessor) {
69        require Config;
70        my $gccLocation = "";
71        if ($ENV{CC}) {
72            $gccLocation = $ENV{CC};
73        } elsif (($Config::Config{'osname'}) =~ /solaris/i) {
74            $gccLocation = "/usr/sfw/bin/gcc";
75        } else {
76            $gccLocation = "/usr/bin/gcc";
77        }
78        $preprocessor = $gccLocation . " -E -P -x c++";
79    }
80
81    if (!$defines) {
82        $defines = "";
83    }
84
85    print " | *** Starting to parse $fileName...\n |\n" unless $beQuiet;
86
87    my $pid = open2(\*PP_OUT, \*PP_IN, split(' ', $preprocessor), (map { "-D$_" } split(' ', $defines)), $fileName);
88    close PP_IN;
89    my @documentContent = <PP_OUT>;
90    close PP_OUT;
91    waitpid($pid, 0);
92
93    my $dataAvailable = 0;
94
95    # Simple IDL Parser (tm)
96    foreach (@documentContent) {
97        my $newParseMode = $object->DetermineParseMode($_);
98
99        if ($newParseMode ne MODE_UNDEF) {
100            if ($dataAvailable eq 0) {
101                $dataAvailable = 1; # Start node building...
102            } else {
103                $object->ProcessSection();
104            }
105        }
106
107        # Update detected data stream mode...
108        if ($newParseMode ne MODE_UNDEF) {
109            $parseMode = $newParseMode;
110        }
111
112        push(@temporaryContent, $_);
113    }
114
115    # Check if there is anything remaining to parse...
116    if (($parseMode ne MODE_UNDEF) and ($#temporaryContent > 0)) {
117        $object->ProcessSection();
118    }
119
120    print " | *** Finished parsing!\n" unless $beQuiet;
121
122    $document->fileName($fileName);
123
124    return $document;
125}
126
127sub ParseModule
128{
129    my $object = shift;
130    my $dataNode = shift;
131
132    print " |- Trying to parse module...\n" unless $beQuiet;
133
134    my $data = join("", @temporaryContent);
135    $data =~ /$IDLStructure::moduleSelector/;
136
137    my $moduleName = (defined($1) ? $1 : die("Parsing error!\nSource:\n$data\n)"));
138    $dataNode->module($moduleName);
139
140    print "  |----> Module; NAME \"$moduleName\"\n |-\n |\n" unless $beQuiet;
141}
142
143sub dumpExtendedAttributes
144{
145    my $padStr = shift;
146    my $attrs = shift;
147
148    if (!%{$attrs}) {
149        return "";
150    }
151
152    my @temp;
153    while ((my $name, my $value) = each(%{$attrs})) {
154        push(@temp, "$name=$value");
155    }
156
157    return $padStr . "[" . join(", ", @temp) . "]";
158}
159
160sub parseExtendedAttributes
161{
162    my $str = shift;
163    $str =~ s/\[\s*(.*?)\s*\]/$1/g;
164
165    my %attrs = ();
166
167    foreach my $value (split(/\s*,\s*/, $str)) {
168        (my $name, my $val) = split(/\s*=\s*/, $value, 2);
169
170        # Attributes with no value are set to be true
171        $val = 1 unless defined $val;
172        $attrs{$name} = $val;
173        die("Invalid extended attribute name: '$name'\n") if $name =~ /\s/;
174    }
175
176    return \%attrs;
177}
178
179sub ParseInterface
180{
181    my $object = shift;
182    my $dataNode = shift;
183    my $sectionName = shift;
184
185    my $data = join("", @temporaryContent);
186
187    # Look for end-of-interface mark
188    $data =~ /};/g;
189    $data = substr($data, index($data, $sectionName), pos($data) - length($data));
190
191    $data =~ s/[\n\r]/ /g;
192
193    # Beginning of the regexp parsing magic
194    if ($sectionName eq "exception") {
195        print " |- Trying to parse exception...\n" unless $beQuiet;
196
197        my $exceptionName = "";
198        my $exceptionData = "";
199        my $exceptionDataName = "";
200        my $exceptionDataType = "";
201
202        # Match identifier of the exception, and enclosed data...
203        $data =~ /$IDLStructure::exceptionSelector/;
204        $exceptionName = (defined($1) ? $1 : die("Parsing error!\nSource:\n$data\n)"));
205        $exceptionData = (defined($2) ? $2 : die("Parsing error!\nSource:\n$data\n)"));
206
207        ('' =~ /^/); # Reset variables needed for regexp matching
208
209        # ... parse enclosed data (get. name & type)
210        $exceptionData =~ /$IDLStructure::exceptionSubSelector/;
211        $exceptionDataType = (defined($1) ? $1 : die("Parsing error!\nSource:\n$data\n)"));
212        $exceptionDataName = (defined($2) ? $2 : die("Parsing error!\nSource:\n$data\n)"));
213
214        # Fill in domClass datastructure
215        $dataNode->name($exceptionName);
216
217        my $newDataNode = new domAttribute();
218        $newDataNode->type("readonly attribute");
219        $newDataNode->signature(new domSignature());
220
221        $newDataNode->signature->name($exceptionDataName);
222        $newDataNode->signature->type($exceptionDataType);
223
224        my $arrayRef = $dataNode->attributes;
225        push(@$arrayRef, $newDataNode);
226
227        print "  |----> Exception; NAME \"$exceptionName\" DATA TYPE \"$exceptionDataType\" DATA NAME \"$exceptionDataName\"\n |-\n |\n" unless $beQuiet;
228    } elsif ($sectionName eq "interface") {
229        print " |- Trying to parse interface...\n" unless $beQuiet;
230
231        my $interfaceName = "";
232        my $interfaceData = "";
233
234        # Match identifier of the interface, and enclosed data...
235        $data =~ /$IDLStructure::interfaceSelector/;
236
237        my $interfaceExtendedAttributes = (defined($1) ? $1 : " "); chop($interfaceExtendedAttributes);
238        $interfaceName = (defined($2) ? $2 : die("Parsing error!\nSource:\n$data\n)"));
239        my $interfaceBase = (defined($3) ? $3 : "");
240        $interfaceData = (defined($4) ? $4 : die("Parsing error!\nSource:\n$data\n)"));
241
242        # Fill in known parts of the domClass datastructure now...
243        $dataNode->name($interfaceName);
244        $dataNode->extendedAttributes(parseExtendedAttributes($interfaceExtendedAttributes));
245
246        # Inheritance detection
247        my @interfaceParents = split(/,/, $interfaceBase);
248        foreach(@interfaceParents) {
249            my $line = $_;
250            $line =~ s/\s*//g;
251
252            my $arrayRef = $dataNode->parents;
253            push(@$arrayRef, $line);
254        }
255
256        return if $parentsOnly;
257
258        $interfaceData =~ s/[\n\r]/ /g;
259        my @interfaceMethods = split(/;/, $interfaceData);
260
261        foreach my $line (@interfaceMethods) {
262            if ($line =~ /\Wattribute\W/) {
263                $line =~ /$IDLStructure::interfaceAttributeSelector/;
264
265                my $attributeType = (defined($1) ? $1 : die("Parsing error!\nSource:\n$line\n)"));
266                my $attributeExtendedAttributes = (defined($2) ? $2 : " "); chop($attributeExtendedAttributes);
267
268                my $attributeDataType = (defined($3) ? $3 : die("Parsing error!\nSource:\n$line\n)"));
269                my $attributeDataName = (defined($4) ? $4 : die("Parsing error!\nSource:\n$line\n)"));
270
271                ('' =~ /^/); # Reset variables needed for regexp matching
272
273                $line =~ /$IDLStructure::getterRaisesSelector/;
274                my $getterException = (defined($1) ? $1 : "");
275
276                $line =~ /$IDLStructure::setterRaisesSelector/;
277                my $setterException = (defined($1) ? $1 : "");
278
279                my $newDataNode = new domAttribute();
280                $newDataNode->type($attributeType);
281                $newDataNode->signature(new domSignature());
282
283                $newDataNode->signature->name($attributeDataName);
284                $newDataNode->signature->type($attributeDataType);
285                $newDataNode->signature->extendedAttributes(parseExtendedAttributes($attributeExtendedAttributes));
286
287                my $arrayRef = $dataNode->attributes;
288                push(@$arrayRef, $newDataNode);
289
290                print "  |  |>  Attribute; TYPE \"$attributeType\" DATA NAME \"$attributeDataName\" DATA TYPE \"$attributeDataType\" GET EXCEPTION? \"$getterException\" SET EXCEPTION? \"$setterException\"" .
291                    dumpExtendedAttributes("\n  |                 ", $newDataNode->signature->extendedAttributes) . "\n" unless $beQuiet;
292
293                $getterException =~ s/\s+//g;
294                $setterException =~ s/\s+//g;
295                @{$newDataNode->getterExceptions} = split(/,/, $getterException);
296                @{$newDataNode->setterExceptions} = split(/,/, $setterException);
297            } elsif (($line !~ s/^\s*$//g) and ($line !~ /^\s*const/)) {
298                $line =~ /$IDLStructure::interfaceMethodSelector/ or die "Parsing error!\nSource:\n$line\n)";
299
300                my $methodExtendedAttributes = (defined($1) ? $1 : " "); chop($methodExtendedAttributes);
301                my $methodType = (defined($2) ? $2 : die("Parsing error!\nSource:\n$line\n)"));
302                my $methodName = (defined($3) ? $3 : die("Parsing error!\nSource:\n$line\n)"));
303                my $methodSignature = (defined($4) ? $4 : die("Parsing error!\nSource:\n$line\n)"));
304
305                ('' =~ /^/); # Reset variables needed for regexp matching
306
307                $line =~ /$IDLStructure::raisesSelector/;
308                my $methodException = (defined($1) ? $1 : "");
309
310                my $newDataNode = new domFunction();
311
312                $newDataNode->signature(new domSignature());
313                $newDataNode->signature->name($methodName);
314                $newDataNode->signature->type($methodType);
315                $newDataNode->signature->extendedAttributes(parseExtendedAttributes($methodExtendedAttributes));
316
317                print "  |  |-  Method; TYPE \"$methodType\" NAME \"$methodName\" EXCEPTION? \"$methodException\"" .
318                    dumpExtendedAttributes("\n  |              ", $newDataNode->signature->extendedAttributes) . "\n" unless $beQuiet;
319
320                $methodException =~ s/\s+//g;
321                @{$newDataNode->raisesExceptions} = split(/,/, $methodException);
322
323                # Split arguments at commas but only if the comma
324                # is not within attribute brackets, expressed here
325                # as being followed by a ']' without a preceding '['.
326                # Note that this assumes that attributes don't nest.
327                my @params = split(/,(?![^[]*\])/, $methodSignature);
328                foreach(@params) {
329                    my $line = $_;
330
331                    $line =~ /$IDLStructure::interfaceParameterSelector/;
332                    my $paramDirection = $1;
333                    my $paramExtendedAttributes = (defined($2) ? $2 : " "); chop($paramExtendedAttributes);
334                    my $paramType = (defined($3) ? $3 : die("Parsing error!\nSource:\n$line\n)"));
335                    my $paramName = (defined($4) ? $4 : die("Parsing error!\nSource:\n$line\n)"));
336
337                    my $paramDataNode = new domSignature();
338                    $paramDataNode->direction($paramDirection);
339                    $paramDataNode->name($paramName);
340                    $paramDataNode->type($paramType);
341                    $paramDataNode->extendedAttributes(parseExtendedAttributes($paramExtendedAttributes));
342
343                    my $arrayRef = $newDataNode->parameters;
344                    push(@$arrayRef, $paramDataNode);
345
346                    print "  |   |>  Param; TYPE \"$paramType\" NAME \"$paramName\"" .
347                        dumpExtendedAttributes("\n  |              ", $paramDataNode->extendedAttributes) . "\n" unless $beQuiet;
348                }
349
350                my $arrayRef = $dataNode->functions;
351                push(@$arrayRef, $newDataNode);
352            } elsif ($line =~ /^\s*const/) {
353                $line =~ /$IDLStructure::constantSelector/;
354                my $constType = (defined($1) ? $1 : die("Parsing error!\nSource:\n$line\n)"));
355                my $constName = (defined($2) ? $2 : die("Parsing error!\nSource:\n$line\n)"));
356                my $constValue = (defined($3) ? $3 : die("Parsing error!\nSource:\n$line\n)"));
357
358                my $newDataNode = new domConstant();
359                $newDataNode->name($constName);
360                $newDataNode->type($constType);
361                $newDataNode->value($constValue);
362
363                my $arrayRef = $dataNode->constants;
364                push(@$arrayRef, $newDataNode);
365
366                print "  |   |>  Constant; TYPE \"$constType\" NAME \"$constName\" VALUE \"$constValue\"\n" unless $beQuiet;
367            }
368        }
369
370        print "  |----> Interface; NAME \"$interfaceName\"" .
371            dumpExtendedAttributes("\n  |                 ", $dataNode->extendedAttributes) . "\n |-\n |\n" unless $beQuiet;
372    }
373}
374
375# Internal helper
376sub DetermineParseMode
377{
378    my $object = shift;
379    my $line = shift;
380
381    my $mode = MODE_UNDEF;
382    if ($_ =~ /module/) {
383        $mode = MODE_MODULE;
384    } elsif ($_ =~ /interface/) {
385        $mode = MODE_INTERFACE;
386    } elsif ($_ =~ /exception/) {
387        $mode = MODE_EXCEPTION;
388    } elsif ($_ =~ /(\A|\b)alias/) {
389        # The (\A|\b) above is needed so we don't match attributes
390        # whose names contain the substring "alias".
391        $mode = MODE_ALIAS;
392    }
393
394    return $mode;
395}
396
397# Internal helper
398sub ProcessSection
399{
400    my $object = shift;
401
402    if ($parseMode eq MODE_MODULE) {
403        die ("Two modules in one file! Fatal error!\n") if ($document ne 0);
404        $document = new idlDocument();
405        $object->ParseModule($document);
406    } elsif ($parseMode eq MODE_INTERFACE) {
407        my $node = new domClass();
408        $object->ParseInterface($node, "interface");
409
410        die ("No module specified! Fatal Error!\n") if ($document eq 0);
411        my $arrayRef = $document->classes;
412        push(@$arrayRef, $node);
413    } elsif($parseMode eq MODE_EXCEPTION) {
414        my $node = new domClass();
415        $object->ParseInterface($node, "exception");
416
417        die ("No module specified! Fatal Error!\n") if ($document eq 0);
418        my $arrayRef = $document->classes;
419        push(@$arrayRef, $node);
420    } elsif($parseMode eq MODE_ALIAS) {
421        print " |- Trying to parse alias...\n" unless $beQuiet;
422
423        my $line = join("", @temporaryContent);
424        $line =~ /$IDLStructure::aliasSelector/;
425
426        my $interfaceName = (defined($1) ? $1 : die("Parsing error!\nSource:\n$line\n)"));
427        my $wrapperName = (defined($2) ? $2 : die("Parsing error!\nSource:\n$line\n)"));
428
429        print "  |----> Alias; INTERFACE \"$interfaceName\" WRAPPER \"$wrapperName\"\n |-\n |\n" unless $beQuiet;
430
431        # FIXME: Check if alias is already in aliases
432        my $aliases = $document->aliases;
433        $aliases->{$interfaceName} = $wrapperName;
434    }
435
436    @temporaryContent = "";
437}
438
4391;
440