WebCore/bindings/scripts/CodeGenerator.pm - WebKit - Git at Google

 #
 # WebKit IDL parser
 #
 # Copyright (C) 2005 Nikolas Zimmermann <wildfox@kde.org>
 # Copyright (C) 2006 Samuel Weinig <sam.weinig@gmail.com>
 # Copyright (C) 2007 Apple Inc. All rights reserved.
 #
 # This library is free software; you can redistribute it and/or
 # modify it under the terms of the GNU Library General Public
 # License as published by the Free Software Foundation; either
 # version 2 of the License, or (at your option) any later version.
 #
 # This library is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 # Library General Public License for more details.
 #
 # You should have received a copy of the GNU Library General Public License
 # aint with this library; see the file COPYING.LIB.  If not, write to
 # the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
 # Boston, MA 02110-1301, USA.
 #

 package CodeGenerator;

 my $useDocument = "";
 my $useGenerator = "";
 my $useOutputDir = "";
 my $useDirectories = "";
 my $useLayerOnTop = 0;
 my $preprocessor;

 my $codeGenerator = 0;

 my $verbose = 0;

 my %primitiveTypeHash = ("int" => 1, "short" => 1, "long" => 1,
                          "unsigned int" => 1, "unsigned short" => 1,
                          "unsigned long" => 1, "float" => 1,
                          "double" => 1, "boolean" => 1, "void" => 1);

 my %podTypeHash = ("RGBColor" => 1, "SVGLength" => 1, "SVGPoint" => 1, "SVGRect" => 1, "SVGNumber" => 1, "SVGMatrix" => 1, "SVGTransform" => 1);

 my %stringTypeHash = ("DOMString" => 1, "AtomicString" => 1);

 my %nonPointerTypeHash = ("DOMTimeStamp" => 1, "CompareHow" => 1, "SVGPaintType" => 1);

 my %svgAnimatedTypeHash = ("SVGAnimatedAngle" => 1, "SVGAnimatedBoolean" => 1,
                            "SVGAnimatedEnumeration" => 1, "SVGAnimatedInteger" => 1,
                            "SVGAnimatedLength" => 1, "SVGAnimatedLengthList" => 1,
                            "SVGAnimatedNumber" => 1, "SVGAnimatedNumberList" => 1,
                            "SVGAnimatedPreserveAspectRatio" => 1,
                            "SVGAnimatedRect" => 1, "SVGAnimatedString" => 1,
                            "SVGAnimatedTransformList" => 1);

 # Helpers for 'ScanDirectory'
 my $endCondition = 0;
 my $foundFilename = "";
 my @foundFilenames = ();
 my $ignoreParent = 1;
 my $defines = "";

 # Default constructor
 sub new
 {
     my $object = shift;
     my $reference = { };

     $useDirectories = shift;
     $useGenerator = shift;
     $useOutputDir = shift;
     $useLayerOnTop = shift;
     $preprocessor = shift;

     bless($reference, $object);
     return $reference;
 }

 sub StripModule($)
 {
     my $object = shift;
     my $name = shift;
     $name =~ s/[a-zA-Z0-9]*:://;
     return $name;
 }

 sub ProcessDocument
 {
     my $object = shift;
     $useDocument = shift;
     $defines = shift;

     my $ifaceName = "CodeGenerator" . $useGenerator;

     # Dynamically load external code generation perl module
     require $ifaceName . ".pm";
     $codeGenerator = $ifaceName->new($object, $useOutputDir, $useLayerOnTop, $preprocessor);
     unless (defined($codeGenerator)) {
         my $classes = $useDocument->classes;
         foreach my $class (@$classes) {
             print "Skipping $useGenerator code generation for IDL interface \"" . $class->name . "\".\n" if $verbose;
         }
         return;
     }

     # Start the actual code generation!
     $codeGenerator->GenerateModule($useDocument, $defines);

     my $classes = $useDocument->classes;
     foreach my $class (@$classes) {
         print "Generating $useGenerator bindings code for IDL interface \"" . $class->name . "\"...\n" if $verbose;
         $codeGenerator->GenerateInterface($class, $defines);
     }

     $codeGenerator->finish();
 }

 sub AddMethodsConstantsAndAttributesFromParentClasses
 {
     # For the passed interface, recursively parse all parent
     # IDLs in order to find out all inherited properties/methods.

     my $object = shift;
     my $dataNode = shift;

     my @parents = @{$dataNode->parents};
     my $parentsMax = @{$dataNode->parents};

     my $constantsRef = $dataNode->constants;
     my $functionsRef = $dataNode->functions;
     my $attributesRef = $dataNode->attributes;

     # Exception: For the DOM 'Node' is our topmost baseclass, not EventTargetNode.
     return if $parentsMax eq 1 and $parents[0] eq "EventTargetNode";

     foreach (@{$dataNode->parents}) {
         if ($ignoreParent) {
             # Ignore first parent class, already handled by the generation itself.
             $ignoreParent = 0;
             next;
         }

         my $interface = $object->StripModule($_);

         # Step #1: Find the IDL file associated with 'interface'
         $endCondition = 0;
         $foundFilename = "";

         foreach (@{$useDirectories}) {
             $object->ScanDirectory("$interface.idl", $_, $_, 0) if ($foundFilename eq "");
         }

         if ($foundFilename ne "") {
             print "  |  |>  Parsing parent IDL \"$foundFilename\" for interface \"$interface\"\n" if $verbose;

             # Step #2: Parse the found IDL file (in quiet mode).
             my $parser = IDLParser->new(1);
             my $document = $parser->Parse($foundFilename, $defines, $preprocessor);

             foreach my $class (@{$document->classes}) {
                 # Step #3: Enter recursive parent search
                 AddMethodsConstantsAndAttributesFromParentClasses($object, $class);

                 # Step #4: Collect constants & functions & attributes of this parent-class
                 my $constantsMax = @{$class->constants};
                 my $functionsMax = @{$class->functions};
                 my $attributesMax = @{$class->attributes};

                 print "  |  |>  -> Inheriting $constantsMax constants, $functionsMax functions, $attributesMax attributes...\n  |  |>\n" if $verbose;

                 # Step #5: Concatenate data
                 push(@$constantsRef, $_) foreach (@{$class->constants});
                 push(@$functionsRef, $_) foreach (@{$class->functions});
                 push(@$attributesRef, $_) foreach (@{$class->attributes});
             }
         } else {
             die("Could NOT find specified parent interface \"$interface\"!\n");
         }
     }
 }

 sub GetMethodsAndAttributesFromParentClasses
 {
     # For the passed interface, recursively parse all parent
     # IDLs in order to find out all inherited properties/methods.

     my $object = shift;
     my $dataNode = shift;

     my @parents = @{$dataNode->parents};

     return if @{$dataNode->parents} == 0;

     my @parentList = ();

     foreach (@{$dataNode->parents}) {
         my $interface = $object->StripModule($_);
         if ($interface eq "EventTargetNode") {
             $interface = "Node";
         }

         # Step #1: Find the IDL file associated with 'interface'
         $endCondition = 0;
         $foundFilename = "";

         foreach (@{$useDirectories}) {
             $object->ScanDirectory("${interface}.idl", $_, $_, 0) if $foundFilename eq "";
         }

         die("Could NOT find specified parent interface \"$interface\"!\n") if $foundFilename eq "";

         print "  |  |>  Parsing parent IDL \"$foundFilename\" for interface \"$interface\"\n" if $verbose;

         # Step #2: Parse the found IDL file (in quiet mode).
         my $parser = IDLParser->new(1);
         my $document = $parser->Parse($foundFilename, $defines);

         foreach my $class (@{$document->classes}) {
             # Step #3: Enter recursive parent search
             push(@parentList, GetMethodsAndAttributesFromParentClasses($object, $class));

             # Step #4: Collect constants & functions & attributes of this parent-class

             # print "  |  |>  -> Inheriting $functionsMax functions amd $attributesMax attributes...\n  |  |>\n" if $verbose;
             my $hash = {
                 "name" => $class->name,
                 "functions" => $class->functions,
                 "attributes" => $class->attributes
             };

             # Step #5: Concatenate data
             unshift(@parentList, $hash);
         }
     }

     return @parentList;
 }

 sub ParseInterface
 {
     my ($object, $interfaceName) = @_;

     # Step #1: Find the IDL file associated with 'interface'
     $endCondition = 0;
     $foundFilename = "";

     foreach (@{$useDirectories}) {
         $object->ScanDirectory("${interfaceName}.idl", $_, $_, 0) if $foundFilename eq "";
     }
     die "Could NOT find specified parent interface \"$interfaceName\"!\n" if $foundFilename eq "";

     print "  |  |>  Parsing parent IDL \"$foundFilename\" for interface \"$interfaceName\"\n" if $verbose;

     # Step #2: Parse the found IDL file (in quiet mode).
     my $parser = IDLParser->new(1);
     my $document = $parser->Parse($foundFilename, $defines);

     foreach my $interface (@{$document->classes}) {
         return $interface if $interface->name eq $interfaceName;
     }

     die "Interface definition not found";
 }

 # Helpers for all CodeGenerator***.pm modules
 sub IsPodType
 {
     my $object = shift;
     my $type = shift;

     return 1 if $podTypeHash{$type};
     return 0;
 }

 sub IsPrimitiveType
 {
     my $object = shift;
     my $type = shift;

     return 1 if $primitiveTypeHash{$type};
     return 0;
 }

 sub IsStringType
 {
     my $object = shift;
     my $type = shift;

     return 1 if $stringTypeHash{$type};
     return 0;
 }

 sub IsNonPointerType
 {
     my $object = shift;
     my $type = shift;

     return 1 if $nonPointerTypeHash{$type} or $primitiveTypeHash{$type};
     return 0;
 }

 sub IsSVGAnimatedType
 {
     my $object = shift;
     my $type = shift;

     return 1 if $svgAnimatedTypeHash{$type};
     return 0;
 }

 # Internal Helper
 sub ScanDirectory
 {
     my $object = shift;

     my $interface = shift;
     my $directory = shift;
     my $useDirectory = shift;
     my $reportAllFiles = shift;

     return if ($endCondition eq 1) and ($reportAllFiles eq 0);

     my $sourceRoot = $ENV{SOURCE_ROOT};
     my $thisDir = $sourceRoot ? "$sourceRoot/$directory" : $directory;

     if (!opendir(DIR, $thisDir)) {
         opendir(DIR, $directory) or die "[ERROR] Can't open directory $thisDir or $directory: \"$!\"\n";
         $thisDir = $directory;
     }

     my @names = readdir(DIR) or die "[ERROR] Cant't read directory $thisDir \"$!\"\n";
     closedir(DIR);

     foreach my $name (@names) {
         # Skip if we already found the right file or
         # if we encounter 'exotic' stuff (ie. '.', '..', '.svn')
         next if ($endCondition eq 1) or ($name =~ /^\./);

         # Recurisvely enter directory
         if (-d "$thisDir/$name") {
             $object->ScanDirectory($interface, "$directory/$name", $useDirectory, $reportAllFiles);
             next;
         }

         # Check wheter we found the desired file
         my $condition = ($name eq $interface);
         $condition = 1 if ($interface eq "allidls") and ($name =~ /\.idl$/);

         if ($condition) {
             $foundFilename = "$thisDir/$name";

             if ($reportAllFiles eq 0) {
                 $endCondition = 1;
             } else {
                 push(@foundFilenames, $foundFilename);
             }
         }
     }
 }

 # Uppercase the first letter while respecting WebKit style guidelines.
 # E.g., xmlEncoding becomes XMLEncoding, but xmlllang becomes Xmllang.
 sub WK_ucfirst
 {
     my ($object, $param) = @_;
     my $ret = ucfirst($param);
     $ret =~ s/Xml/XML/ if $ret =~ /^Xml[^a-z]/;
     return $ret;
 }

 # Lowercase the first letter while respecting WebKit style guidelines.
 # URL becomes url, but SetURL becomes setURL.
 sub WK_lcfirst
 {
     my ($object, $param) = @_;
     my $ret = lcfirst($param);
     $ret =~ s/uRL/url/ if $ret =~ /^uRL/;
     $ret =~ s/jS/js/ if $ret =~ /^jS/;
     return $ret;
 }

 1;
	#
	# WebKit IDL parser
	#
	# Copyright (C) 2005 Nikolas Zimmermann <wildfox@kde.org>
	# Copyright (C) 2006 Samuel Weinig <sam.weinig@gmail.com>
	# Copyright (C) 2007 Apple Inc. All rights reserved.
	#
	# This library is free software; you can redistribute it and/or
	# modify it under the terms of the GNU Library General Public
	# License as published by the Free Software Foundation; either
	# version 2 of the License, or (at your option) any later version.
	#
	# This library is distributed in the hope that it will be useful,
	# but WITHOUT ANY WARRANTY; without even the implied warranty of
	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	# Library General Public License for more details.
	#
	# You should have received a copy of the GNU Library General Public License
	# aint with this library; see the file COPYING.LIB. If not, write to
	# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
	# Boston, MA 02110-1301, USA.
	#

	package CodeGenerator;

	my $useDocument = "";
	my $useGenerator = "";
	my $useOutputDir = "";
	my $useDirectories = "";
	my $useLayerOnTop = 0;
	my $preprocessor;

	my $codeGenerator = 0;

	my $verbose = 0;

	my %primitiveTypeHash = ("int" => 1, "short" => 1, "long" => 1,
	"unsigned int" => 1, "unsigned short" => 1,
	"unsigned long" => 1, "float" => 1,
	"double" => 1, "boolean" => 1, "void" => 1);

	my %podTypeHash = ("RGBColor" => 1, "SVGLength" => 1, "SVGPoint" => 1, "SVGRect" => 1, "SVGNumber" => 1, "SVGMatrix" => 1, "SVGTransform" => 1);

	my %stringTypeHash = ("DOMString" => 1, "AtomicString" => 1);

	my %nonPointerTypeHash = ("DOMTimeStamp" => 1, "CompareHow" => 1, "SVGPaintType" => 1);

	my %svgAnimatedTypeHash = ("SVGAnimatedAngle" => 1, "SVGAnimatedBoolean" => 1,
	"SVGAnimatedEnumeration" => 1, "SVGAnimatedInteger" => 1,
	"SVGAnimatedLength" => 1, "SVGAnimatedLengthList" => 1,
	"SVGAnimatedNumber" => 1, "SVGAnimatedNumberList" => 1,
	"SVGAnimatedPreserveAspectRatio" => 1,
	"SVGAnimatedRect" => 1, "SVGAnimatedString" => 1,
	"SVGAnimatedTransformList" => 1);

	# Helpers for 'ScanDirectory'
	my $endCondition = 0;
	my $foundFilename = "";
	my @foundFilenames = ();
	my $ignoreParent = 1;
	my $defines = "";

	# Default constructor
	sub new
	{
	my $object = shift;
	my $reference = { };

	$useDirectories = shift;
	$useGenerator = shift;
	$useOutputDir = shift;
	$useLayerOnTop = shift;
	$preprocessor = shift;

	bless($reference, $object);
	return $reference;
	}

	sub StripModule($)
	{
	my $object = shift;
	my $name = shift;
	$name =~ s/[a-zA-Z0-9]*:://;
	return $name;
	}

	sub ProcessDocument
	{
	my $object = shift;
	$useDocument = shift;
	$defines = shift;

	my $ifaceName = "CodeGenerator" . $useGenerator;

	# Dynamically load external code generation perl module
	require $ifaceName . ".pm";
	$codeGenerator = $ifaceName->new($object, $useOutputDir, $useLayerOnTop, $preprocessor);
	unless (defined($codeGenerator)) {
	my $classes = $useDocument->classes;
	foreach my $class (@$classes) {
	print "Skipping $useGenerator code generation for IDL interface \"" . $class->name . "\".\n" if $verbose;
	}
	return;
	}

	# Start the actual code generation!
	$codeGenerator->GenerateModule($useDocument, $defines);

	my $classes = $useDocument->classes;
	foreach my $class (@$classes) {
	print "Generating $useGenerator bindings code for IDL interface \"" . $class->name . "\"...\n" if $verbose;
	$codeGenerator->GenerateInterface($class, $defines);
	}

	$codeGenerator->finish();
	}

	sub AddMethodsConstantsAndAttributesFromParentClasses
	{
	# For the passed interface, recursively parse all parent
	# IDLs in order to find out all inherited properties/methods.

	my $object = shift;
	my $dataNode = shift;

	my @parents = @{$dataNode->parents};
	my $parentsMax = @{$dataNode->parents};

	my $constantsRef = $dataNode->constants;
	my $functionsRef = $dataNode->functions;
	my $attributesRef = $dataNode->attributes;

	# Exception: For the DOM 'Node' is our topmost baseclass, not EventTargetNode.
	return if $parentsMax eq 1 and $parents[0] eq "EventTargetNode";

	foreach (@{$dataNode->parents}) {
	if ($ignoreParent) {
	# Ignore first parent class, already handled by the generation itself.
	$ignoreParent = 0;
	next;
	}

	my $interface = $object->StripModule($_);

	# Step #1: Find the IDL file associated with 'interface'
	$endCondition = 0;
	$foundFilename = "";

	foreach (@{$useDirectories}) {
	$object->ScanDirectory("$interface.idl", $_, $_, 0) if ($foundFilename eq "");
	}

	if ($foundFilename ne "") {
	print " \| \|> Parsing parent IDL \"$foundFilename\" for interface \"$interface\"\n" if $verbose;

	# Step #2: Parse the found IDL file (in quiet mode).
	my $parser = IDLParser->new(1);
	my $document = $parser->Parse($foundFilename, $defines, $preprocessor);

	foreach my $class (@{$document->classes}) {
	# Step #3: Enter recursive parent search
	AddMethodsConstantsAndAttributesFromParentClasses($object, $class);

	# Step #4: Collect constants & functions & attributes of this parent-class
	my $constantsMax = @{$class->constants};
	my $functionsMax = @{$class->functions};
	my $attributesMax = @{$class->attributes};

	print " \| \|> -> Inheriting $constantsMax constants, $functionsMax functions, $attributesMax attributes...\n \| \|>\n" if $verbose;

	# Step #5: Concatenate data
	push(@$constantsRef, $_) foreach (@{$class->constants});
	push(@$functionsRef, $_) foreach (@{$class->functions});
	push(@$attributesRef, $_) foreach (@{$class->attributes});
	}
	} else {
	die("Could NOT find specified parent interface \"$interface\"!\n");
	}
	}
	}

	sub GetMethodsAndAttributesFromParentClasses
	{
	# For the passed interface, recursively parse all parent
	# IDLs in order to find out all inherited properties/methods.

	my $object = shift;
	my $dataNode = shift;

	my @parents = @{$dataNode->parents};

	return if @{$dataNode->parents} == 0;

	my @parentList = ();

	foreach (@{$dataNode->parents}) {
	my $interface = $object->StripModule($_);
	if ($interface eq "EventTargetNode") {
	$interface = "Node";
	}

	# Step #1: Find the IDL file associated with 'interface'
	$endCondition = 0;
	$foundFilename = "";

	foreach (@{$useDirectories}) {
	$object->ScanDirectory("${interface}.idl", $_, $_, 0) if $foundFilename eq "";
	}

	die("Could NOT find specified parent interface \"$interface\"!\n") if $foundFilename eq "";

	print " \| \|> Parsing parent IDL \"$foundFilename\" for interface \"$interface\"\n" if $verbose;

	# Step #2: Parse the found IDL file (in quiet mode).
	my $parser = IDLParser->new(1);
	my $document = $parser->Parse($foundFilename, $defines);

	foreach my $class (@{$document->classes}) {
	# Step #3: Enter recursive parent search
	push(@parentList, GetMethodsAndAttributesFromParentClasses($object, $class));

	# Step #4: Collect constants & functions & attributes of this parent-class

	# print " \| \|> -> Inheriting $functionsMax functions amd $attributesMax attributes...\n \| \|>\n" if $verbose;
	my $hash = {
	"name" => $class->name,
	"functions" => $class->functions,
	"attributes" => $class->attributes
	};

	# Step #5: Concatenate data
	unshift(@parentList, $hash);
	}
	}

	return @parentList;
	}

	sub ParseInterface
	{
	my ($object, $interfaceName) = @_;

	# Step #1: Find the IDL file associated with 'interface'
	$endCondition = 0;
	$foundFilename = "";

	foreach (@{$useDirectories}) {
	$object->ScanDirectory("${interfaceName}.idl", $_, $_, 0) if $foundFilename eq "";
	}
	die "Could NOT find specified parent interface \"$interfaceName\"!\n" if $foundFilename eq "";

	print " \| \|> Parsing parent IDL \"$foundFilename\" for interface \"$interfaceName\"\n" if $verbose;

	# Step #2: Parse the found IDL file (in quiet mode).
	my $parser = IDLParser->new(1);
	my $document = $parser->Parse($foundFilename, $defines);

	foreach my $interface (@{$document->classes}) {
	return $interface if $interface->name eq $interfaceName;
	}

	die "Interface definition not found";
	}

	# Helpers for all CodeGenerator***.pm modules
	sub IsPodType
	{
	my $object = shift;
	my $type = shift;

	return 1 if $podTypeHash{$type};
	return 0;
	}

	sub IsPrimitiveType
	{
	my $object = shift;
	my $type = shift;

	return 1 if $primitiveTypeHash{$type};
	return 0;
	}

	sub IsStringType
	{
	my $object = shift;
	my $type = shift;

	return 1 if $stringTypeHash{$type};
	return 0;
	}

	sub IsNonPointerType
	{
	my $object = shift;
	my $type = shift;

	return 1 if $nonPointerTypeHash{$type} or $primitiveTypeHash{$type};
	return 0;
	}

	sub IsSVGAnimatedType
	{
	my $object = shift;
	my $type = shift;

	return 1 if $svgAnimatedTypeHash{$type};
	return 0;
	}

	# Internal Helper
	sub ScanDirectory
	{
	my $object = shift;

	my $interface = shift;
	my $directory = shift;
	my $useDirectory = shift;
	my $reportAllFiles = shift;

	return if ($endCondition eq 1) and ($reportAllFiles eq 0);

	my $sourceRoot = $ENV{SOURCE_ROOT};
	my $thisDir = $sourceRoot ? "$sourceRoot/$directory" : $directory;

	if (!opendir(DIR, $thisDir)) {
	opendir(DIR, $directory) or die "[ERROR] Can't open directory $thisDir or $directory: \"$!\"\n";
	$thisDir = $directory;
	}

	my @names = readdir(DIR) or die "[ERROR] Cant't read directory $thisDir \"$!\"\n";
	closedir(DIR);

	foreach my $name (@names) {
	# Skip if we already found the right file or
	# if we encounter 'exotic' stuff (ie. '.', '..', '.svn')
	next if ($endCondition eq 1) or ($name =~ /^\./);

	# Recurisvely enter directory
	if (-d "$thisDir/$name") {
	$object->ScanDirectory($interface, "$directory/$name", $useDirectory, $reportAllFiles);
	next;
	}

	# Check wheter we found the desired file
	my $condition = ($name eq $interface);
	$condition = 1 if ($interface eq "allidls") and ($name =~ /\.idl$/);

	if ($condition) {
	$foundFilename = "$thisDir/$name";

	if ($reportAllFiles eq 0) {
	$endCondition = 1;
	} else {
	push(@foundFilenames, $foundFilename);
	}
	}
	}
	}

	# Uppercase the first letter while respecting WebKit style guidelines.
	# E.g., xmlEncoding becomes XMLEncoding, but xmlllang becomes Xmllang.
	sub WK_ucfirst
	{
	my ($object, $param) = @_;
	my $ret = ucfirst($param);
	$ret =~ s/Xml/XML/ if $ret =~ /^Xml[^a-z]/;
	return $ret;
	}

	# Lowercase the first letter while respecting WebKit style guidelines.
	# URL becomes url, but SetURL becomes setURL.
	sub WK_lcfirst
	{
	my ($object, $param) = @_;
	my $ret = lcfirst($param);
	$ret =~ s/uRL/url/ if $ret =~ /^uRL/;
	$ret =~ s/jS/js/ if $ret =~ /^jS/;
	return $ret;
	}

	1;