Copy the KDE 3.5 branch to branches/trinity for new KDE 3.5 features.

BUG:215923


git-svn-id: svn://anonsvn.kde.org/home/kde/branches/trinity/kdelibs@1054174 283d02a7-25f6-0310-bc7c-ecb5cbfe19da

1 files changed, 213 insertions, 0 deletions

diff --git a/dcop/dcopidlng/kalyptusCxxToDcopIDL.pm b/dcop/dcopidlng/kalyptusCxxToDcopIDL.pm
new file mode 100644
index 000000000..8a2988f06
--- /dev/null
+++ b/dcop/dcopidlng/kalyptusCxxToDcopIDL.pm
@@ -0,0 +1,213 @@
+#***************************************************************************
+#            kalyptusCxxToDcopIDL.pm -  Generates idl from dcop headers
+#                             -------------------
+#    begin                : Fri Jan 25 12:00:00 2000
+#    copyright            : (C) 2003 Alexander Kellett
+#    email                : [email protected]
+#    author               : Alexander Kellett
+#***************************************************************************/
+
+#/***************************************************************************
+# *                                                                         *
+# *   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 kalyptusCxxToDcopIDL;
+
+use File::Path;
+use File::Basename;
+use Carp;
+use Ast;
+use kdocAstUtil;
+use kdocUtil;
+use Iter;
+
+use strict;
+no strict "subs";
+
+use vars qw/$libname $rootnode $outputdir $opt $debug/;
+
+BEGIN
+{
+}
+
+sub writeDoc
+{
+	( $libname, $rootnode, $outputdir, $opt ) = @_;
+
+	$debug = $main::debuggen;
+
+	print STDERR "Preparsing...\n";
+
+	# Preparse everything, to prepare some additional data in the classes and methods
+	Iter::LocalCompounds( $rootnode, sub { preParseClass( shift ); } );
+
+	kdocAstUtil::dumpAst($rootnode) if ($debug);
+
+	print STDERR "Writing dcopidl...\n";
+
+	print STDOUT "<!DOCTYPE DCOP-IDL><DCOP-IDL>\n";
+
+	print STDOUT "<SOURCE>".@{$rootnode->{Sources}}[0]->{astNodeName}."</SOURCE>\n";
+
+	print STDOUT map { "<INCLUDE>$_</INCLUDE>\n" } @main::includes_list;
+
+	Iter::LocalCompounds( $rootnode, sub { 
+	    my ($node) = @_;
+
+	    my ($methodCode) = generateAllMethods( $node );
+	    my $className = join "::", kdocAstUtil::heritage($node);
+
+	    if ($node->{DcopExported}) {
+		print STDOUT "<CLASS>\n";
+		print STDOUT "    <NAME>$className</NAME>\n";
+		print STDOUT "    <LINK_SCOPE>$node->{Export}</LINK_SCOPE>\n" if ($node->{Export});
+		print STDOUT join("\n", map { "    <SUPER>$_</SUPER>"; } grep { $_ ne "Global"; }
+			     map {
+				my $name = $_->{astNodeName};
+				$name =~ s/</&lt;/;
+				$name =~ s/>/&gt;/;
+				my $tmpl = $_->{TmplType};
+				$tmpl =~ s/</&lt;/;
+				$tmpl =~ s/>/&gt;/;
+				$tmpl ? "$name&lt;<TYPE>$tmpl</TYPE>&gt;" : $name;
+			     } @{$node->{InList}}) . "\n";
+		print STDOUT $methodCode;
+
+		print STDOUT "</CLASS>\n";
+	    }
+	});
+
+	print STDOUT "</DCOP-IDL>\n";
+	
+	print STDERR "Done.\n";
+}
+
+=head2 preParseClass
+	Called for each class
+=cut
+sub preParseClass
+{
+	my( $classNode ) = @_;
+	my $className = join( "::", kdocAstUtil::heritage($classNode) );
+
+	if( $#{$classNode->{Kids}} < 0 ||
+	    $classNode->{Access} eq "private" ||
+	    $classNode->{Access} eq "protected" || # e.g. QPixmap::QPixmapData
+	    exists $classNode->{Tmpl} ||
+	    $classNode->{NodeType} eq 'union' # Skip unions for now, e.g. QPDevCmdParam
+	  ) {
+	    print STDERR "Skipping $className\n" if ($debug);
+	    print STDERR "Skipping union $className\n" if ( $classNode->{NodeType} eq 'union');
+	    delete $classNode->{Compound}; # Cheat, to get it excluded from Iter::LocalCompounds
+	    return;
+	}
+}
+
+
+sub generateMethod($$)
+{
+    my( $classNode, $m ) = @_;	# input
+    my $methodCode = '';	# output
+
+    my $name = $m->{astNodeName}; # method name
+    my @heritage = kdocAstUtil::heritage($classNode);
+    my $className  = join( "::", @heritage );
+
+    # Check some method flags: constructor, destructor etc.
+    my $flags = $m->{Flags};
+
+    if ( !defined $flags ) {
+	warn "Method ".$name.  " has no flags\n";
+    }
+
+    my $returnType = $m->{ReturnType};
+    $returnType = undef if ($returnType eq 'void');
+
+    # Don't use $className here, it's never the fully qualified (A::B) name for a ctor.
+    my $isConstructor = ($name eq $classNode->{astNodeName} );
+    my $isDestructor = ($returnType eq '~');
+
+    if ($debug) {
+        print STDERR " Method $name";
+	print STDERR ", is DTOR" if $isDestructor;
+	print STDERR ", returns $returnType" if $returnType;
+	#print STDERR " ($m->{Access})";
+	print STDERR "\n";
+    }
+
+    # Don't generate anything for destructors
+    return if $isDestructor;
+
+    my $args = "";
+
+    foreach my $arg ( @{$m->{ParamList}} ) {
+
+	print STDERR "  Param ".$arg->{astNodeName}." type: ".$arg->{ArgType}." name:".$arg->{ArgName}." default: ".$arg->{DefaultValue}."\n" if ($debug);
+
+	my $argType = $arg->{ArgType};
+
+	my $x_isConst = ($argType =~ s/const//);
+	my $x_isRef = ($argType =~ s/&//);
+
+	my $typeAttrs = "";
+	$typeAttrs .= "  qleft=\"const\"" if $x_isConst;
+	$typeAttrs .= " qright=\"&amp;\"" if $x_isRef;
+
+	$argType =~ s/^\s*(.*?)\s*$/$1/;
+	$argType =~ s/</&lt;/g;
+	$argType =~ s/>/&gt;/g;
+	$argType =~ s/\s//g;
+
+	$args .= "        <ARG><TYPE$typeAttrs>$argType</TYPE><NAME>$arg->{ArgName}</NAME></ARG>\n";
+    }
+
+    my $qual = "";
+    $qual .= " qual=\"const\"" if $flags =~ "c";
+
+    $returnType = "void" unless $returnType;
+    $returnType =~ s/</&lt;/g;
+    $returnType =~ s/>/&gt;/g;
+    $returnType =~ s/^\s*const\s*//;
+
+    my $methodCode = "";
+
+    my $tagType = ($flags !~ /z/) ? "FUNC" : "SIGNAL";
+    my $tagAttr = "";
+    $tagAttr .= " hidden=\"yes\"" if $flags =~ /y/;
+
+    if (!$isConstructor) {
+	$methodCode .= "    <$tagType$tagAttr$qual>\n";
+	$methodCode .= "        <TYPE>$returnType</TYPE>\n";
+	$methodCode .= "        <NAME>$name</NAME>\n";
+	$methodCode .= "$args";
+	$methodCode .= "     </$tagType>\n";
+    }
+
+    return ( $methodCode );
+}
+
+sub generateAllMethods
+{
+    my ($classNode) = @_;
+    my $methodCode = '';
+
+    # Then all methods
+    Iter::MembersByType ( $classNode, undef,
+			  sub {	my ($classNode, $methodNode ) = @_;
+
+        if ( $methodNode->{NodeType} eq 'method' ) {
+	    next unless $methodNode->{Flags} =~ /(d|z|y)/;
+	    my ($meth) = generateMethod( $classNode, $methodNode );
+	    $methodCode .= $meth;
+	}
+			      }, undef );
+
+    return ( $methodCode );
+}
+
+1;