You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
libtqt-perl/kalyptus/kalyptusCxxToECMA.pm

571 lines
18 KiB

#***************************************************************************
# kalyptusCxxToEMA.pm - Generates class info for ECMA bindings in KDE
# -------------------
# begin : Fri Jan 25 12:00:00 2000
# copyright : (C) 2002 Lost Highway Ltd. All Rights Reserved.
# email : david@mandrakesoft.com
# author : David Faure.
#***************************************************************************/
#/***************************************************************************
# * *
# * This program is free software; you can redistribute it and/or modify *
# * it under the terms of the GNU General Public License as published by *
# * the Free Software Foundation; either version 2 of the License, or *
# * (at your option) any later version. *
# * *
#***************************************************************************/
package kalyptusCxxToECMA;
use File::Path;
use File::Basename;
use Carp;
use Ast;
use kdocAstUtil;
use kdocUtil;
use Iter;
use kalyptusDataDict;
use strict;
no strict "subs";
use vars qw/
$libname $rootnode $outputdir $opt $debug
%skippedClasses %hasHashTable %hasFunctions %hasBridge %hasGet %hasPut/;
sub writeDoc
{
( $libname, $rootnode, $outputdir, $opt ) = @_;
print STDERR "Starting writeDoc for $libname...\n";
$debug = $main::debuggen;
mkpath( $outputdir ) unless -f $outputdir;
# Preparse everything, to prepare some additional data in the classes and methods
Iter::LocalCompounds( $rootnode, sub { preParseClass( shift ); } );
print STDERR "Writing generateddata.cpp...\n";
writeInheritanceFile($rootnode);
print STDERR "Done.\n";
}
=head2 preParseClass
Called for each class
=cut
sub preParseClass
{
my( $classNode ) = @_;
my $className = join( "::", kdocAstUtil::heritage($classNode) );
if ( $className =~ /Proto$/ ) {
my $c = $className;
$c =~ s/Proto$//;
#print STDERR "$c -> $className\n";
$hasFunctions{$c} = $className; # Associate class -> proto
#print STDERR "Found proto $className -> skipping\n";
$skippedClasses{$className} = 1; # Skip proto
return;
}
if( $classNode->{Access} eq "private" ||
$classNode->{Access} eq "protected" || # e.g. TQPixmap::TQPixmapData
exists $classNode->{Tmpl} ||
$className eq 'KJS' || $className eq 'KSVG' || # namespaces
$className =~ /^KSVG::KSVG/ || $className eq 'KSVG::CachedGlyph' || # Not DOM classes
$className eq 'KSVG::ImageStreamMap' ||
$className eq 'KSVG::SVGBBoxTarget' ||
$className eq 'KSVG::SVGLoader' ||
$className eq 'KSVG::SVGElementImpl::MouseEvent' ||
$className eq 'KSVG::SVGRegisteredEventListener' ||
$classNode->{NodeType} eq 'union' # Skip unions for now, e.g. TQPDevCmdParam
) {
print STDERR "Skipping $className "; #if ($debug);
#print STDERR "(nothing in it)\n" if ( $#{$classNode->{Kids}} < 0 );
if ( exists $classNode->{Tmpl} ) {
print STDERR "(template)\n";
} elsif ( $classNode->{Access} eq "private" or $classNode->{Access} eq "protected" ) {
print STDERR "(not public)\n";
} elsif ( $classNode->{NodeType} eq 'union') {
print STDERR "(union)\n";
} elsif ( $className =~ /^KSVG::KSVG/ || $className eq 'KSVG::CachedGlyph' ) {
print STDERR "(not a DOM class)\n";
} else {
print STDERR "\n";
}
$skippedClasses{$className} = 1;
#delete $classNode->{Compound}; # Cheat, to get it excluded from Iter::LocalCompounds
# Can't do that, it's recursive (KSVG::* disappears)
return;
}
# Iterate over methods
Iter::MembersByType ( $classNode, undef,
sub { my ($classNode, $methodNode ) = @_;
if ( $methodNode->{NodeType} eq 'method' ) {
if ( $methodNode->{astNodeName} eq 'get' ) {
$hasGet{$className} = '1';
} elsif ( $methodNode->{astNodeName} eq 'getforward' ) {
$hasGet{$className} = '2';
} elsif ( $methodNode->{astNodeName} eq 'put' ) {
$hasPut{$className} = '1';
} elsif ( $methodNode->{astNodeName} eq 'putforward' ) {
$hasPut{$className} = '2';
} elsif ( $methodNode->{astNodeName} eq 'getValueProperty' ) {
$hasHashTable{$className} = '1';
} elsif ( $methodNode->{astNodeName} eq 'bridge' ) {
$hasBridge{$className} = '1';
}
}
} );
}
# List of all super-classes for a given class
sub superclass_list($)
{
my $classNode = shift;
my @super;
Iter::Ancestors( $classNode, $rootnode, undef, undef, sub {
push @super, @_[0];
push @super, superclass_list( @_[0] );
}, undef );
return @super;
}
# Adds the header for node $1 to be included in $2 if not already there
# Prints out debug stuff if $3
sub addIncludeForClass($$$)
{
my ( $node, $addInclude, $debugMe ) = @_;
my $sourcename = $node->{Source}->{astNodeName};
$sourcename =~ s!.*/(.*)!$1!m;
unless ( defined $addInclude->{$sourcename} ) {
print " Including $sourcename\n" if ($debugMe);
$addInclude->{$sourcename} = 1;
}
else { print " $sourcename already included.\n" if ($debugMe); }
}
=head2
Write out the smokedata.cpp file containing all the arrays.
=cut
sub writeInheritanceFile($) {
my $rootnode = shift;
# Make list of classes
my %allIncludes; # list of all header files for all classes
my @classlist;
push @classlist, ""; # Prepend empty item for "no class"
Iter::LocalCompounds( $rootnode, sub {
my $classNode = $_[0];
my $className = join( "::", kdocAstUtil::heritage($classNode) );
return if ( defined $skippedClasses{$className} );
push @classlist, $className;
$classNode->{ClassIndex} = $#classlist;
addIncludeForClass( $classNode, \%allIncludes, undef );
} );
my %classidx = do { my $i = 0; map { $_ => $i++ } @classlist };
#foreach my $debugci (keys %classidx) {
# print STDERR "$debugci: $classidx{$debugci}\n";
#}
my $file = "$outputdir/generateddata.cpp";
open OUT, ">$file" or die "Couldn't create $file\n";
print OUT "#include <ksvg_lookup.h>\n";
print OUT "#include <ksvg_ecma.h>\n";
foreach my $incl (keys %allIncludes) {
die if $incl eq '';
print OUT "#include <$incl>\n";
}
print OUT "\n";
# Prepare descendants information for each class
my %descendants; # classname -> list of descendant nodes
#my $SVGElementImplNode;
Iter::LocalCompounds( $rootnode, sub {
my $classNode = shift;
my $className = join( "::", kdocAstUtil::heritage($classNode) );
# Get _all_ superclasses (up any number of levels)
# and store that $classNode is a descendant of $s
my @super = superclass_list($classNode);
for my $s (@super) {
my $superClassName = join( "::", kdocAstUtil::heritage($s) );
Ast::AddPropList( \%descendants, $superClassName, $classNode );
}
# Found SVGElementImpl itself
if ( $className eq 'KSVG::SVGElementImpl' ) {
$classNode->{IsSVGElement} = '1';
#$SVGElementImplNode = $classNode;
}
} );
# Mark all SVGElementImpl descendants as svg elements
if ( defined $descendants{'KSVG::SVGElementImpl'} ) {
my @desc = @{$descendants{'KSVG::SVGElementImpl'}};
for my $d (@desc) {
$d->{IsSVGElement} = '1' ;
print STDERR $d->{astNodeName}. " is an SVGElement\n" if($debug);
}
}
# Propagate $hasPut and $hasGet
Iter::LocalCompounds( $rootnode, sub {
my $classNode = shift;
my $className = join( "::", kdocAstUtil::heritage($classNode) );
if ( defined $descendants{$className} ) {
my @desc = @{$descendants{$className}};
for my $d (@desc) {
my $c = join( "::", kdocAstUtil::heritage($d) );
$hasPut{$c} = '2' if (!$hasPut{$c} && $hasPut{$className});
$hasGet{$c} = '2' if (!$hasGet{$c} && $hasGet{$className});
}
}
# This code prints out the base classes - useful for KSVG_BASECLASS_GET
if ( 0 && defined $descendants{$className} ) {
my $baseClass = 1;
Iter::Ancestors( $classNode, $rootnode, sub { # called if no ancestors
}, undef, sub { # called for each ancestor
my $superClassName = join( "::", kdocAstUtil::heritage($_[0]) );
$baseClass = 0 if ( $superClassName ne '' ); # happens with unknown parents;
} );
print STDERR "$className is a base class.\n" if ($baseClass);
}
} );
# Write namespaces
print OUT "using namespace KSVG;\n";
print OUT "using namespace KJS;\n\n";
# Write classInfos
print OUT "// For all classes with generated data: the ClassInfo\n";
Iter::LocalCompounds( $rootnode, sub {
my $classNode = shift;
my $className = join( "::", kdocAstUtil::heritage($classNode) );
# We use namespace declartions!
my $printName = $className;
$printName =~ s/KSVG:://;
# Write tagNames
if ($hasBridge{$className}) {
my $tagName = $printName;
$tagName =~ s/SVG//;
$tagName =~ s/ElementImpl//;
$tagName = lcfirst($tagName);
# Special cases, otherwhise they'd be "tRef" / "tSpan" / "sVG"
if($printName eq "SVGTRefElementImpl" or
$printName eq "SVGTSpanElementImpl" or
$printName eq "SVGSVGElementImpl") {
$tagName =~ tr/A-Z/a-z/;
}
while($tagName =~ /[A-Z]/g) {
# Special case: color-profile instead of ie. animateColor/animateMotion
if($printName eq "SVGColorProfileElementImpl") {
$tagName = substr($tagName, 0, pos($tagName) - 1) . "-" . lc($&) . substr($tagName, pos($tagName));
}
}
# Special cases: gradient & poly aren't element!
if($tagName ne "" and $tagName ne "gradient" and $tagName ne "poly") {
print OUT "const DOM::DOMString ${printName}::s_tagName = \"$tagName\";\n";
}
}
# Skip classes without KSVG_GENERATEDDATA
if (!$hasGet{$className} && !$skippedClasses{$className}) {
$skippedClasses{$className} = '1' ;
print STDERR "Skipping $className, no get()\n";
}
return if ( defined $skippedClasses{$className} );
my $ok = $hasHashTable{$className};
print STDERR "$className has get() but no hashtable - TODO\n" if (!$ok && $hasGet{$className} eq '1');
print OUT "const ClassInfo ${printName}::s_classInfo = {\"$className\",0,";
if ($ok) {
print OUT "\&${printName}::s_hashTable";
} else {
print OUT "0";
}
print OUT ",0};\n";
#die "problem with $className" unless defined $classinherit{$className};
#print OUT "const short int ${className}::s_inheritanceIndex = $classinherit{$className};\n";
} );
# Generated methods
print OUT "\n";
Iter::LocalCompounds( $rootnode, sub {
my $classNode = shift;
my $className = join( "::", kdocAstUtil::heritage($classNode) );
return if ( defined $skippedClasses{$className} );
# We use namespace declartions!
my $printName = $className;
$printName =~ s/KSVG:://;
my $paramsUsed = 0;
print OUT "bool ${printName}::hasProperty(ExecState *p1,const Identifier &p2) const\n";
print OUT "{\n";
if ($hasHashTable{$className}) {
print OUT " const HashEntry *e = Lookup::findEntry(\&${printName}::s_hashTable,p2);\n";
print OUT " if(e) return true;\n";
$paramsUsed=1;
}
# Now look in prototype, if it exists
if ( defined $hasFunctions{$className} ) {
# We use namespace declartions!
my $output = $hasFunctions{$className};
$output =~ s/KSVG:://;
print OUT " Object proto = " . $output . "::self(p1);\n";
print OUT " if(proto.hasProperty(p1,p2)) return true;\n";
}
# For each direct ancestor...
Iter::Ancestors( $classNode, $rootnode, undef, undef, sub {
my $superClassName = join( "::", kdocAstUtil::heritage($_[0]) );
# We use namespace declartions!
my $printSuperClassName = $superClassName;
$printSuperClassName =~ s/KSVG:://;
if ( $superClassName ne '' ) { # happens with unknown parents
return if ( defined $skippedClasses{$superClassName} );
print OUT " if(${printSuperClassName}::hasProperty(p1,p2)) return true;\n";
$paramsUsed=2;
}
}, undef );
if ($paramsUsed == 1 && !defined $hasFunctions{$className}){
print OUT " Q_UNUSED(p1);\n";
}
if ($paramsUsed == 0){
print OUT " Q_UNUSED(p1); Q_UNUSED(p2);\n";
}
print OUT " return false;\n";
print OUT "}\n\n";
my @ancestorsWithGet;
Iter::Ancestors( $classNode, $rootnode, undef, undef, sub {
my $superClassName = join( "::", kdocAstUtil::heritage($_[0]) );
if ( $superClassName ne '' # happens with unknown parents
&& ! defined $skippedClasses{$superClassName} ) {
if ( $hasGet{$superClassName} ) {
push @ancestorsWithGet, $superClassName;
}
}
}, undef );
if ($hasHashTable{$className}) {
die unless $hasGet{$className};
if ( $hasGet{$className} eq '1' ) {
print OUT "Value ${printName}::get(GET_METHOD_ARGS) const\n";
print OUT "{\n";
if ( defined $hasFunctions{$className} ) {
# We use namespace declartions!
my $output = $hasFunctions{$className};
$output =~ s/KSVG:://;
print OUT " return lookupGet<${output}Func,${printName}>(p1,p2,&s_hashTable,this,p3);\n";
} else {
print OUT " return lookupGetValue<${printName}>(p1,p2,&s_hashTable,this,p3);\n";
}
print OUT "}\n\n";
if ( defined $hasFunctions{$className} ) {
# We use namespace declartions!
my $output = $hasFunctions{$className};
$output =~ s/KSVG:://;
my $methodName = "${output}Func::cast";
my $const = 'const';
# Special case - we also need that code in toNode()
if ($methodName eq 'SVGDOMNodeBridgeProtoFunc::cast') {
print OUT "${printName} *$methodName(const ObjectImp *p1) const\n";
$methodName = 'KSVG::toNodeBridge';
print OUT "{\n";
print OUT " return $methodName(p1);\n";
print OUT "}\n\n";
$const = '';
}
# Type resolver for the Func class
print OUT "${printName} *$methodName(const ObjectImp *p1) $const\n";
print OUT "{\n";
my @toTry;
push @toTry, $classNode;
if ( defined $descendants{$className} ) {
push @toTry, @{$descendants{$className}};
}
foreach my $d (@toTry) {
my $c = join( "::", kdocAstUtil::heritage($d) );
# We use namespace declartions!
my $d = $c;
$d =~ s/KSVG:://;
print OUT " { const KSVGBridge<$d> *test = dynamic_cast<const KSVGBridge<$d> * >(p1);\n";
print OUT " if(test) return test->impl(); }\n";
}
print OUT " return 0;\n";
print OUT "}\n\n";
}
}
}
my $methodName = $hasGet{$className} eq '1' ? 'getInParents' : 'get';
print OUT "Value ${printName}::$methodName(GET_METHOD_ARGS) const\n";
print OUT "{\n";
my $paramsUsed = 0;
# Now look in prototype, if it exists
if ( defined $hasFunctions{$className} ) {
# Prototype exists (because the class has functions)
# We use namespace declartions!
my $output = $hasFunctions{$className};
$output =~ s/KSVG:://;
print OUT " Object proto = " . $output . "::self(p1);\n";
print OUT " if(proto.hasProperty(p1,p2)) return proto.get(p1,p2);\n"; ## TODO get() directly
$paramsUsed = 1;
}
foreach my $anc (@ancestorsWithGet) {
# We use namespace declartions!
my $printAnc = $anc;
$printAnc =~ s/KSVG:://;
print OUT " if(${printAnc}::hasProperty(p1,p2)) return ${printAnc}::get(p1,p2,p3);\n"; ## TODO get() directly
$paramsUsed = 2;
}
if ($paramsUsed == 0 ){
print OUT " Q_UNUSED(p1); Q_UNUSED(p2); Q_UNUSED(p3);\n";
} elsif ( $paramsUsed == 1 ) {
print OUT " Q_UNUSED(p3);\n";
}
print OUT " return Undefined();\n";
print OUT "}\n\n";
if ( $hasPut{$className} )
{
if ( $hasPut{$className} eq '1' ) {
if ($hasHashTable{$className}) {
print OUT "bool ${printName}::put(PUT_METHOD_ARGS)\n";
print OUT "{\n";
print OUT " return lookupPut<${printName}>(p1,p2,p3,p4,&s_hashTable,this);\n";
print OUT "}\n\n";
}
print OUT "bool ${printName}::putInParents(PUT_METHOD_ARGS)\n";
} else { # forward put
print OUT "bool ${printName}::put(PUT_METHOD_ARGS)\n";
}
print OUT "{\n";
my $paramsUsed = 0;
Iter::Ancestors( $classNode, $rootnode, undef, undef, sub {
my $superClassName = join( "::", kdocAstUtil::heritage($_[0]) );
# We use namespace declartions!
my $printSuperClassName = $superClassName;
$printSuperClassName =~ s/KSVG:://;
if ( $superClassName ne '' ) { # happens with unknown parents
if ( $hasPut{$superClassName} ) {
print OUT " if(${printSuperClassName}::hasProperty(p1,p2)) {\n";
print OUT " ${printSuperClassName}::put(p1,p2,p3,p4);\n";
print OUT " return true;\n";
print OUT " }\n";
$paramsUsed=1;
}
}
}, undef );
if (!$paramsUsed){
print OUT " Q_UNUSED(p1); Q_UNUSED(p2); Q_UNUSED(p3); Q_UNUSED(p4);\n";
}
print OUT " return false;\n";
print OUT "}\n\n";
}
# Write prototype method
print OUT "Object ${printName}::prototype(ExecState *p1) const\n";
print OUT "{\n";
if ( defined $hasFunctions{$className} ) {
# We use namespace declartions!
my $output = $hasFunctions{$className};
$output =~ s/KSVG:://;
# Prototype exists (because the class has functions)
print OUT " if(p1) return " . $output . "::self(p1);\n";
} else {
# Standard Object prototype
print OUT " if(p1) return p1->interpreter()->builtinObjectPrototype();\n";
}
print OUT " return Object::dynamicCast(Null());\n"; # hmm
print OUT "}\n\n";
# Process classes only with KSVG_BRIDGE
if ($hasBridge{$className}) {
#print STDERR "Writing bridge() for $className...\n";
# Write bridge method
print OUT "ObjectImp *${printName}::bridge(ExecState *p1) const\n";
print OUT "{\n";
if ($hasPut{$className})
{
print OUT " return new KSVGRWBridge<${printName}>(p1,const_cast<${printName} *>(this));\n";
}
else
{
print OUT " return new KSVGBridge<${printName}>(p1,const_cast<${printName} *>(this));\n";
}
print OUT "}\n\n";
}
if ($hasGet{$className}) {
# Write cache method
print OUT "Value ${printName}::cache(ExecState *p1) const\n";
print OUT "{\n";
if ($hasPut{$className})
{
print OUT " return KJS::Value(cacheDOMObject<${printName},KSVGRWBridge<${printName}> >(p1,const_cast<${printName} *>(this)));\n";
}
else
{
print OUT " return KJS::Value(cacheDOMObject<${printName},KSVGBridge<${printName}> >(p1,const_cast<${printName} *>(this)));\n";
}
print OUT "}\n\n";
}
} );
}
1;