#*************************************************************************** # kalyptusCxxToDcopIDL.pm - Generates idl from dcop headers # ------------------- # begin : Fri Jan 25 12:00:00 2000 # copyright : (C) 2003 Alexander Kellett # email : lypanov@kde.org # 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 kalyptusDataDict; use Data::Dumper; use strict; no strict "subs"; use vars qw/ $libname $rootnode $outputdir $opt $debug $methodNumber %builtins %typeunion %allMethods %allTypes %enumValueToType %typedeflist %mungedTypeMap %skippedClasses /; BEGIN { # Types supported by the StackItem union # Key: C++ type Value: Union field of that type %typeunion = ( 'void*' => 's_voidp', 'bool' => 's_bool', 'char' => 's_char', 'uchar' => 's_uchar', 'short' => 's_short', 'ushort' => 's_ushort', 'int' => 's_int', 'uint' => 's_uint', 'long' => 's_long', 'ulong' => 's_ulong', 'float' => 's_float', 'double' => 's_double', 'enum' => 's_enum', 'class' => 's_class' ); # Mapping for iterproto, when making up the munged method names %mungedTypeMap = ( 'TQString' => '$', 'TQString*' => '$', 'TQString&' => '$', 'TQCString' => '$', 'TQCString*' => '$', 'TQCString&' => '$', 'TQByteArray' => '$', 'TQByteArray&' => '$', 'TQByteArray*' => '$', 'char*' => '$', 'TQCOORD*' => '?', 'TQRgb*' => '?', ); # Yes some of this is in kalyptusDataDict's ctypemap # but that one would need to be separated (builtins vs normal classes) %typedeflist = ( 'signed char' => 'char', 'unsigned char' => 'uchar', 'signed short' => 'short', 'unsigned short' => 'ushort', 'signed' => 'int', 'signed int' => 'int', 'unsigned' => 'uint', 'unsigned int' => 'uint', 'signed long' => 'long', 'unsigned long' => 'ulong', # Anything that is not known is mapped to void*, so no need for those here anymore # 'TQWSEvent*' => 'void*', # 'TQDiskFont*' => 'void*', # 'XEvent*' => 'void*', # 'TQStyleHintReturn*' => 'void*', # 'FILE*' => 'void*', # 'TQUnknownInterface*' => 'void*', # 'GDHandle' => 'void*', # '_NPStream*' => 'void*', # 'TQTextFormat*' => 'void*', # 'TQTextDocument*' => 'void*', # 'TQTextCursor*' => 'void*', # 'TQTextParag**' => 'void*', # 'TQTextParag*' => 'void*', # 'TQRemoteInterface*' => 'void*', # 'TQSqlRecordPrivate*' => 'void*', # 'TQTSMFI' => 'void*', # TQTextStream's TQTSManip # 'const GUID&' => 'void*', # 'TQWidgetMapper*' => 'void*', # 'MSG*' => 'void*', # 'const TQSqlFieldInfoList&' => 'void*', # TQSqlRecordInfo - TODO (templates) 'TQPtrCollection::Item' => 'void*', # to avoid a warning 'mode_t' => 'long', 'TQProcess::PID' => 'long', 'size_type' => 'int', # TQSqlRecordInfo 'TQt::ComparisonFlags' => 'uint', 'TQt::ToolBarDock' => 'int', # compat thing, Qt shouldn't use it 'TQIODevice::Offset' => 'ulong', 'WState' => 'int', 'WId' => 'ulong', 'TQRgb' => 'uint', 'TQCOORD' => 'int', 'TQTSMFI' => 'int', 'TQt::WState' => 'int', 'TQt::WFlags' => 'int', 'TQt::HANDLE' => 'uint', 'TQEventLoop::ProcessEventsFlags' => 'uint', 'TQStyle::SCFlags' => 'int', 'TQStyle::SFlags' => 'int', 'Q_INT16' => 'short', 'Q_INT32' => 'int', 'Q_INT8' => 'char', 'Q_LONG' => 'long', 'Q_UINT16' => 'ushort', 'Q_UINT32' => 'uint', 'Q_UINT8' => 'uchar', 'Q_ULONG' => 'long', ); } sub writeDoc { ( $libname, $rootnode, $outputdir, $opt ) = @_; print STDERR "Starting writeDoc for $libname...\n"; $debug = $main::debuggen; # Define TQPtrCollection::Item, for resolveType unless ( kdocAstUtil::findRef( $rootnode, "TQPtrCollection::Item" ) ) { my $cNode = kdocAstUtil::findRef( $rootnode, "TQPtrCollection" ); warn "TQPtrCollection not found" if (!$cNode); my $node = Ast::New( 'Item' ); $node->AddProp( "NodeType", "Forward" ); $node->AddProp( "Source", $cNode->{Source} ) if ($cNode); kdocAstUtil::attachChild( $cNode, $node ) if ($cNode); $node->AddProp( "Access", "public" ); } print STDERR "Preparsing...\n"; # Preparse everything, to prepare some additional data in the classes and methods Iter::LocalCompounds( $rootnode, sub { preParseClass( shift ); } ); print STDERR "Writing smokedata.cpp...\n"; # Write out smokedata.cpp writeSmokeDataFile($rootnode); print STDERR "Writing dcopidl...\n"; print STDOUT "\n"; print STDOUT "".@{$rootnode->{Sources}}[0]->{astNodeName}."\n"; print STDOUT map { "$_\n" } reverse @main::includes_list; Iter::LocalCompounds( $rootnode, sub { my ($node) = @_; my ($methodCode, $switchCode, $incl) = generateAllMethods( $node ); my $className = join "::", kdocAstUtil::heritage($node); if ($node->{DcopExported}) { print STDOUT "\n"; my @docs; if ($node->{DocNode}->{Text}) { for my $blah ($node->{DocNode}->{Text}) { for my $blah2 (@{$blah}) { push @docs, $blah2->{astNodeName} if $blah2->{NodeType} eq "DocText"; } } } if (scalar(@docs) != 0) { my $doc = join "", map { "$_" } @docs; print STDOUT " $doc\n"; } print STDOUT " $className\n"; print STDOUT join("\n", map { " $_"; } grep { $_ ne "Global"; } map { my $name = $_->{astNodeName}; $name =~ s//>/; my $tmpl = $_->{TmplType}; $tmpl =~ s//>/; $tmpl ? "$name<$tmpl>" : $name; } @{$node->{InList}}) . "\n"; print STDOUT $methodCode; print STDOUT "\n"; } }); print STDOUT "\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. TQPixmap::TQPixmapData exists $classNode->{Tmpl} || # Don't generate standard bindings for TQString, this class is handled as a native type $className eq 'TQString' || $className eq 'TQConstString' || $className eq 'TQCString' || # Don't map classes which are really arrays $className eq 'TQStringList' || $className eq 'TQCanvasItemList' || $className eq 'TQWidgetList' || $className eq 'TQObjectList' || $className eq 'TQStrList' || # Those are template related $className eq 'TQTSManip' || # cause compiler errors with several gcc versions $className eq 'TQGDict' || $className eq 'TQGList' || $className eq 'TQGVector' || $className eq 'TQStrIList' || $className eq 'TQStrIVec' || $className eq 'TQByteArray' || $className eq 'TQBitArray' || $classNode->{NodeType} eq 'union' # Skip unions for now, e.g. TQPDevCmdParam ) { print STDERR "Skipping $className\n" if ($debug); print STDERR "Skipping union $className\n" if ( $classNode->{NodeType} eq 'union'); $skippedClasses{$className} = 1; delete $classNode->{Compound}; # Cheat, to get it excluded from Iter::LocalCompounds return; } my $signalCount = 0; my $eventHandlerCount = 0; my $defaultConstructor = 'none'; # none, public, protected or private. 'none' will become 'public'. my $constructorCount = 0; # total count of _all_ ctors # If there are ctors, we need at least one public/protected one to instanciate the class my $hasPublicProtectedConstructor = 0; # We need a public dtor to destroy the object --- ### aren't protected dtors ok too ?? my $hasPublicDestructor = 1; # by default all classes have a public dtor! my $hasDestructor = 0; my $hasPrivatePureVirtual = 0; my $hasCopyConstructor = 0; my $hasPrivateCopyConstructor = 0; # Note: no need for hasPureVirtuals. $classNode{Pure} has that. my $doPrivate = $main::doPrivate; $main::doPrivate = 1; # Look at each class member (looking for methods and enums in particular) Iter::MembersByType ( $classNode, undef, sub { my( $classNode, $m ) = @_; my $name = $m->{astNodeName}; if( $m->{NodeType} eq "method" ) { if ( $m->{ReturnType} eq 'typedef' # TQFile's EncoderFn/DecoderFn callback, very badly parsed ) { $m->{NodeType} = 'deleted'; next; } print STDERR "preParseClass: looking at $className\::$name $m->{Params}\n" if ($debug); if ( $name eq $classNode->{astNodeName} ) { if ( $m->{ReturnType} =~ /~/ ) { # A destructor $hasPublicDestructor = 0 if $m->{Access} ne 'public'; $hasDestructor = 1; } else { # A constructor $constructorCount++; $defaultConstructor = $m->{Access} if ( $m->{Params} eq '' ); $hasPublicProtectedConstructor = 1 if ( $m->{Access} ne 'private' ); # Copy constructor? if ( $#{$m->{ParamList}} == 0 ) { my $theArgType = @{$m->{ParamList}}[0]->{ArgType}; if ($theArgType =~ /$className\s*\&/) { $hasCopyConstructor = 1; $hasPrivateCopyConstructor = 1 if ( $m->{Access} eq 'private' ); } } # Hack the return type for constructors, since constructors return an object pointer $m->{ReturnType} = $className."*"; } } if ( $name =~ /~$classNode->{astNodeName}/ && $m->{Access} ne "private" ) { # not used $hasPublicDestructor = 0 if $m->{Access} ne 'public'; $hasDestructor = 1; } if ( $m->{Flags} =~ "p" && $m->{Access} =~ /private/ ) { $hasPrivatePureVirtual = 1; # ouch, can't inherit from that one } # All we want from private methods is to check for virtuals, nothing else next if ( $m->{Access} =~ /private/ ); my $argId = 0; my $firstDefaultParam; foreach my $arg ( @{$m->{ParamList}} ) { # Look for first param with a default value if ( defined $arg->{DefaultValue} && !defined $firstDefaultParam ) { $firstDefaultParam = $argId; } if ( $arg->{ArgType} eq '...' # refuse a method with variable arguments or $arg->{ArgType} eq 'image_io_handler' # TQImage's callback or $arg->{ArgType} eq 'DecoderFn' # TQFile's callback or $arg->{ArgType} eq 'EncoderFn' # TQFile's callback or $arg->{ArgType} =~ /bool \(\*\)\(TQObject/ # TQMetaObject's ctor or $arg->{ArgType} eq 'QtStaticMetaObjectFunction' # TQMetaObjectCleanUp's ctor with func pointer or $arg->{ArgType} eq 'const TQTextItem&' # ref to a private class in 3.2.0b1 or $arg->{ArgType} eq 'FILE*' # won't be able to handle that I think ) { $m->{NodeType} = 'deleted'; } else { # Resolve type in full, e.g. for TQSessionManager::RestartHint # (x_QSessionManager doesn't inherit TQSessionManager) $arg->{ArgType} = kalyptusDataDict::resolveType($arg->{ArgType}, $classNode, $rootnode); registerType( $arg->{ArgType} ); $argId++; } } $m->AddProp( "FirstDefaultParam", $firstDefaultParam ); $m->{ReturnType} = kalyptusDataDict::resolveType($m->{ReturnType}, $classNode, $rootnode) if ($m->{ReturnType}); registerType( $m->{ReturnType} ); } elsif( $m->{NodeType} eq "enum" ) { my $fullEnumName = $className."::".$m->{astNodeName}; $classNode->{enumerations}{$m->{astNodeName}} = $fullEnumName if $m->{astNodeName} and $m->{Access} ne 'private'; # Define a type for this enum registerType( $fullEnumName ); # Remember that it's an enum findTypeEntry( $fullEnumName )->{isEnum} = 1; #print STDERR "$fullEnumName is an enum\n"; } elsif( $m->{NodeType} eq 'var' ) { my $varType = $m->{Type}; # We are interested in public static vars, like TQColor::blue if ( $varType =~ s/static\s+// && $m->{Access} ne 'private' ) { $varType =~ s/const\s+(.*)\s*&/$1/; $varType =~ s/\s*$//; print STDERR "var: $m->{astNodeName} '$varType'\n" if ($debug); # Register the type registerType( $varType ); } else { # To avoid duplicating the above test, we just get rid of any other var $m->{NodeType} = 'deleted'; } } }, undef ); $main::doPrivate = $doPrivate; print STDERR "$className: ctor count: $constructorCount, hasPublicProtectedConstructor: $hasPublicProtectedConstructor, hasCopyConstructor: $hasCopyConstructor:, defaultConstructor: $defaultConstructor, hasPublicDestructor: $hasPublicDestructor, hasPrivatePureVirtual:$hasPrivatePureVirtual\n" if ($debug); # We will derive from the class only if it has public or protected constructors. # (_Even_ if it has pure virtuals. But in that case the x_ class can't be instantiated either.) $classNode->AddProp( "BindingDerives", $hasPublicProtectedConstructor ); } =head2 writeClassDoc Called by writeDoc for each series of classes to be written out =cut sub writeClassDoc { } # Generate the prototypes for a method (one per arg with a default value) # Helper for makeprotos sub iterproto($$$$$) { my $classidx = shift; # to check if a class exists my $method = shift; my $proto = shift; my $idx = shift; my $protolist = shift; my $argcnt = scalar @{ $method->{ParamList} } - 1; if($idx > $argcnt) { push @$protolist, $proto; return; } if(defined $method->{FirstDefaultParam} and $method->{FirstDefaultParam} <= $idx) { push @$protolist, $proto; } my $arg = $method->{ParamList}[$idx]->{ArgType}; my $typeEntry = findTypeEntry( $arg ); my $realType = $typeEntry->{realType}; # A scalar ? $arg =~ s/\bconst\b//g; $arg =~ s/\s+//g; if($typeEntry->{isEnum} || $allTypes{$realType}{isEnum} || exists $typeunion{$realType} || exists $mungedTypeMap{$arg}) { my $id = '$'; # a 'scalar $id = '?' if $arg =~ /[*&]{2}/; $id = $mungedTypeMap{$arg} if exists $mungedTypeMap{$arg}; iterproto($classidx, $method, $proto . $id, $idx + 1, $protolist); return; } # A class ? if(exists $classidx->{$realType}) { iterproto($classidx, $method, $proto . '#', $idx + 1, $protolist); return; } # A non-scalar (reference to array or hash, undef) iterproto($classidx, $method, $proto . '?', $idx + 1, $protolist); return; } # Generate the prototypes for a method (one per arg with a default value) sub makeprotos($$$) { my $classidx = shift; my $method = shift; my $protolist = shift; iterproto($classidx, $method, $method->{astNodeName}, 0, $protolist); } # Return the string containing the signature for this method (without return type). # If the 2nd arg is not the size of $m->{ParamList}, this method returns a # partial signature (this is used to handle default values). sub methodSignature($$) { my $method = shift; my $last = shift; my $sig = $method->{astNodeName}; my @argTypeList; my $argId = 0; foreach my $arg ( @{$method->{ParamList}} ) { last if $argId > $last; push @argTypeList, $arg->{ArgType}; $argId++; } $sig .= "(". join(", ",@argTypeList) .")"; $sig .= " const" if $method->{Flags} =~ "c"; return $sig; } sub coerce_type($$$$) { #my $m = shift; my $union = shift; my $var = shift; my $type = shift; my $new = shift; # 1 if this is a return value, 0 for a normal param my $typeEntry = findTypeEntry( $type ); my $realType = $typeEntry->{realType}; my $unionfield = $typeEntry->{typeId}; die "$type" unless defined( $unionfield ); $unionfield =~ s/t_/s_/; $type =~ s/\s+const$//; # for 'char* const' $type =~ s/\s+const\s*\*$/\*/; # for 'char* const*' my $code = "$union.$unionfield = "; if($type =~ /&$/) { $code .= "(void*)&$var;\n"; } elsif($type =~ /\*$/) { $code .= "(void*)$var;\n"; } else { if ( $unionfield eq 's_class' or ( $unionfield eq 's_voidp' and $type ne 'void*' ) or $type eq 'TQString' ) { # hack $type =~ s/^const\s+//; if($new) { $code .= "(void*)new $type($var);\n"; } else { $code .= "(void*)&$var;\n"; } } else { $code .= "$var;\n"; } } return $code; } # Generate the list of args casted to their real type, e.g. # (TQObject*)x[1].s_class,(TQEvent*)x[2].s_class,x[3].s_int sub makeCastedArgList { my @castedList; my $i = 1; # The args start at x[1]. x[0] is the return value my $arg; foreach $arg (@_) { my $type = $arg; my $cast; my $typeEntry = findTypeEntry( $type ); my $unionfield = $typeEntry->{typeId}; die "$type" unless defined( $unionfield ); $unionfield =~ s/t_/s_/; $type =~ s/\s+const$//; # for 'char* const' $type =~ s/\s+const\s*\*$/\*/; # for 'char* const*' my $v .= "$unionfield"; if($type =~ s/&$//) { $cast = "{($type *)}"; } elsif($type =~ /\*$/) { $cast = "$type"; } elsif($type =~ /\(\*\)\s*\(/) { # function pointer ... (*)(...) $cast = "$type"; } else { if ( $unionfield eq 's_class' or ( $unionfield eq 's_voidp' and $type ne 'void*' ) or $type eq 'TQString' ) { # hack $cast = "{*($type *)}"; } else { $cast = "$type"; } } push @castedList, "$cast$v"; $i++; } return @castedList; } # 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; die "Empty source name for $node->{astNodeName}" if ( $sourcename eq '' ); unless ( defined $addInclude->{$sourcename} ) { print " Including $sourcename\n" if ($debugMe); $addInclude->{$sourcename} = 1; } else { print " $sourcename already included.\n" if ($debugMe); } } sub checkIncludesForObject($$) { my $type = shift; my $addInclude = shift; my $debugCI = 0; #$debug #print "checkIncludesForObject $type\n"; $type =~ s/const\s+//; my $it = $type; if (!($it and exists $typeunion{$it}) and $type !~ /\*/ #and $type !~ /&/ # in fact we also want refs, due to the generated code ) { $type =~ s/&//; print " Detecting an object by value/ref: $type\n" if ($debugCI); my $node = kdocAstUtil::findRef( $rootnode, $type ); if ($node) { addIncludeForClass( $node, $addInclude, $debugCI ); } else { print " No header found for $type\n" if ($debugCI); } } } sub generateMethod($$$) { my( $classNode, $m, $addInclude ) = @_; # input my $methodCode = ''; # output my $name = $m->{astNodeName}; # method name my @heritage = kdocAstUtil::heritage($classNode); my $className = join( "::", @heritage ); my $xClassName = "x_" . 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; return if ( $m->{SkipFromSwitch} ); # pure virtuals, etc. # # Skip internal methods, which return unknown types # # Hmm, the C# bindings have a list of those too. # return if ( $returnType =~ m/TQGfx\s*\*/ ); # return if ( $returnType eq 'CGContextRef' ); # return if ( $returnType eq 'TQWSDisplay *' ); # # This stuff needs callback, or ** # return if ( $name eq 'defineIOHandler' or $name eq 'qt_init_internal' ); # # Skip casting operators, but not == < etc. # return if ( $name =~ /operator \w+/ ); # # TQFile's EncoderFn/DecoderFn # return if ( $name =~ /set[ED][ne]codingFunction/ ); # # How to implement this? (TQXmlDefaultHandler/TQXmlEntityResolver::resolveEntity, needs A*&) # return if ( $name eq 'resolveEntity' and $className =~ /^TQXml/ ); # return if ( $className eq 'TQBitArray' && $m->{Access} eq 'protected' ); #print STDERR "Tests passed, generating.\n"; # Detect objects returned by value checkIncludesForObject( $returnType, $addInclude ) if ($returnType); my $argId = 0; my @argTypeList=(); 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=\"&\"" if $x_isRef; $argType =~ s/^\s*(.*?)\s*$/$1/; $argType =~ s//>/g; $args .= " $argType$arg->{ArgName}\n"; push @argTypeList, $argType; # Detect objects passed by value checkIncludesForObject( $argType, $addInclude ); } # my @castedArgList = makeCastedArgList( @argTypeList ); my $isStatic = ($flags =~ "s"); my $extra = ""; $extra .= "static " if $isStatic || $isConstructor; my $qual = ""; $qual .= " qual=\"const\"" if $flags =~ "c"; my $this = $classNode->{BindingDerives} > 0 ? "this" : "xthis"; # We iterate as many times as we have default params my $firstDefaultParam = $m->{FirstDefaultParam}; $firstDefaultParam = scalar(@argTypeList) unless defined $firstDefaultParam; my $xretCode = ''; if($returnType) { $xretCode .= coerce_type('x[0]', 'xret', $returnType, 1); } $returnType = "void" unless $returnType; $returnType =~ s//>/g; my $methodCode = ""; my $tagType = ($flags !~ /z/) ? "FUNC" : "SIGNAL"; my $tagAttr = ""; $tagAttr .= " hidden=\"yes\"" if $flags =~ /y/; if (!$isConstructor) { $methodCode .= " <$tagType$tagAttr$qual>\n"; my @docs; if ($m->{DocNode}->{Text}) { for my $blah ($m->{DocNode}->{Text}) { for my $blah2 (@{$blah}) { push @docs, $blah2->{astNodeName} if $blah2->{NodeType} eq "DocText"; } } } if (scalar(@docs) != 0) { my $doc = join "", map { "$_" } @docs; $methodCode .= " $doc\n"; } $methodCode .= " $returnType\n"; $methodCode .= " $name\n"; $methodCode .= "$args"; $methodCode .= " \n"; } $methodNumber++; return ( $methodCode, "" ); } ## Called by writeClassDoc sub generateAllMethods { my ($classNode) = @_; my $methodCode = ''; my $sourcename = $classNode->{Source}->{astNodeName}; $sourcename =~ s!.*/(.*)!$1!m; die "Empty source name for $classNode->{astNodeName}" if ( $sourcename eq '' ); my %addInclude = ( $sourcename => 1 ); # 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, $swit) = generateMethod( $classNode, $methodNode, \%addInclude ); $methodCode .= $meth; } }, undef ); return ( $methodCode, "", \%addInclude ); } # Known typedef? If so, apply it. sub applyTypeDef($) { my $type = shift; # Parse 'const' in front of it, and '*' or '&' after it my $prefix = $type =~ s/^const\s+// ? 'const ' : ''; my $suffix = $type =~ s/\s*([\&\*]+)$// ? $1 : ''; if (exists $typedeflist{$type}) { return $prefix.$typedeflist{$type}.$suffix; } return $prefix.$type.$suffix; } # Register type ($1) into %allTypes if not already there sub registerType($$) { my $type = shift; #print "registerType: $type\n" if ($debug); $type =~ s/\s+const$//; # for 'char* const' $type =~ s/\s+const\s*\*$/\*/; # for 'char* const*' return if ( $type eq 'void' or $type eq '' or $type eq '~' ); die if ( $type eq '...' ); # ouch # Let's register the real type, not its known equivalent #$type = applyTypeDef($type); # Enum _value_ -> get corresponding type if (exists $enumValueToType{$type}) { $type = $enumValueToType{$type}; } # Already in allTypes if(exists $allTypes{$type}) { return; } die if $type eq 'TQTextEdit::UndoRedoInfo::Type'; die if $type eq ''; my $realType = $type; # Look for references (&) and pointers (* or **) - this will not handle *& correctly. # We do this parsing here because both the type list and iterproto need it if($realType =~ s/&$//) { $allTypes{$type}{typeFlags} = 'Smoke::tf_ref'; } elsif($realType ne 'void*' && $realType =~ s/\*$//) { $allTypes{$type}{typeFlags} = 'Smoke::tf_ptr'; } else { $allTypes{$type}{typeFlags} = 'Smoke::tf_stack'; } if ( $realType =~ s/^const\s+// ) { # Remove 'const' $allTypes{$type}{typeFlags} .= ' | Smoke::tf_const'; } # Apply typedefs, and store the resulting type. # For instance, if $type was Q_UINT16&, realType will be ushort $allTypes{$type}{realType} = applyTypeDef( $realType ); # In the first phase we only create entries into allTypes. # The values (indexes) are calculated afterwards, once the list is full. $allTypes{$type}{index} = -1; #print STDERR "Register $type. Realtype: $realType\n" if($debug); } # Get type from %allTypes # This returns a hash with {index}, {isEnum}, {typeFlags}, {realType} # (and {typeId} after the types array is written by writeSmokeDataFile) sub findTypeEntry($) { my $type = shift; my $typeIndex = -1; $type =~ s/\s+const$//; # for 'char* const' $type =~ s/\s+const\s*\*$/\*/; # for 'char* const*' return undef if ( $type =~ '~' or $type eq 'void' or $type eq '' ); # Enum _value_ -> get corresponding type if (exists $enumValueToType{$type}) { $type = $enumValueToType{$type}; } die "type not known: $type" unless defined $allTypes{$type}; return $allTypes{ $type }; } # 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; } =head2 Write out the smokedata.cpp file containing all the arrays. =cut sub writeSmokeDataFile($) { 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" my %enumclasslist; Iter::LocalCompounds( $rootnode, sub { my $classNode = $_[0]; my $className = join( "::", kdocAstUtil::heritage($classNode) ); push @classlist, $className; $enumclasslist{$className}++ if keys %{$classNode->{enumerations}}; $classNode->{ClassIndex} = $#classlist; addIncludeForClass( $classNode, \%allIncludes, undef ); } ); kdocAstUtil::dumpAst($rootnode) if ($debug); my %classidx = do { my $i = 0; map { $_ => $i++ } @classlist }; my $file = "$outputdir/smokedata.cpp"; open OUT, ">$file" or die "Couldn't create $file\n"; # Prepare descendants information for each class my %descendants; # classname -> list of descendant nodes Iter::LocalCompounds( $rootnode, sub { my $classNode = shift; # 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 ); } } ); # Iterate over all classes, to write the xtypecast function Iter::LocalCompounds( $rootnode, sub { my $classNode = shift; my $className = join( "::", kdocAstUtil::heritage($classNode) ); # @super will contain superclasses, the class itself, and all descendants my @super = superclass_list($classNode); push @super, $classNode; if ( defined $descendants{$className} ) { push @super, @{$descendants{$className}}; } my $cur = $classidx{$className}; print OUT " case $cur:\t//$className\n"; print OUT "\tswitch(to) {\n"; $cur = -1; for my $s (@super) { my $superClassName = join( "::", kdocAstUtil::heritage($s) ); next if !defined $classidx{$superClassName}; # inherits from unknown class, see below next if $classidx{$superClassName} == $cur; # shouldn't happen in Qt $cur = $classidx{$superClassName}; print OUT "\t case $cur: return (void*)($superClassName*)($className*)xptr;\n"; } print OUT "\t default: return xptr;\n"; print OUT "\t}\n"; } ); print OUT " default: return xptr;\n"; print OUT " }\n"; print OUT "}\n\n"; # Write inheritance array # Imagine you have "Class : public super1, super2" # The inheritlist array will get 3 new items: super1, super2, 0 my %inheritfinder; # key = (super1, super2) -> data = (index in @inheritlist). This one allows reuse. my %classinherit; # we store that index in %classinherit{className} # We don't actually need to store inheritlist in memory, we write it # directly to the file. We only need to remember its current size. my $inheritlistsize = 1; print OUT "// Group of class IDs (0 separated) used as super class lists.\n"; print OUT "// Classes with super classes have an index into this array.\n"; print OUT "static short ${libname}_inheritanceList[] = {\n"; print OUT "\t0,\t// 0: (no super class)\n"; Iter::LocalCompounds( $rootnode, sub { my $classNode = shift; my $className = join( "__", kdocAstUtil::heritage($classNode) ); print STDERR "inheritanceList: looking at $className\n" if ($debug); # Make list of direct ancestors my @super; Iter::Ancestors( $classNode, $rootnode, undef, undef, sub { my $superClassName = join( "::", kdocAstUtil::heritage($_[0]) ); push @super, $superClassName; }, undef ); # Turn that into a list of class indexes my $key = ''; foreach my $superClass( @super ) { if (defined $classidx{$superClass}) { $key .= ', ' if ( length $key > 0 ); $key .= $classidx{$superClass}; } } if ( $key ne '' ) { if ( !defined $inheritfinder{$key} ) { print OUT "\t"; my $index = $inheritlistsize; # Index of first entry (for this group) in inheritlist foreach my $superClass( @super ) { if (defined $classidx{$superClass}) { print OUT "$classidx{$superClass}, "; $inheritlistsize++; } } $inheritlistsize++; my $comment = join( ", ", @super ); print OUT "0,\t// $index: $comment\n"; $inheritfinder{$key} = $index; } $classinherit{$className} = $inheritfinder{$key}; } else { # No superclass $classinherit{$className} = 0; } } ); print OUT "};\n\n"; print OUT "// These are the xenum functions for manipulating enum pointers\n"; for my $className (keys %enumclasslist) { my $c = $className; $c =~ s/::/__/g; print OUT "void xenum_$c\(Smoke::EnumOperation, Smoke::Index, void*&, long&);\n"; } print OUT "\n"; print OUT "// Those are the xcall functions defined in each x_*.cpp file, for dispatching method calls\n"; my $firstClass = 1; for my $className (@classlist) { if ($firstClass) { $firstClass = 0; next; } my $c = $className; # make a copy $c =~ s/::/__/g; print OUT "void xcall_$c\(Smoke::Index, void*, Smoke::Stack);\n"; } print OUT "\n"; # Write class list afterwards because it needs offsets to the inheritance array. print OUT "// List of all classes\n"; print OUT "// Name, index into inheritanceList, method dispatcher, enum dispatcher, class flags\n"; print OUT "static Smoke::Class ${libname}_classes[] = {\n"; my $firstClass = 1; Iter::LocalCompounds( $rootnode, sub { my $classNode = shift; my $className = join( "__", kdocAstUtil::heritage($classNode) ); if ($firstClass) { $firstClass = 0; print OUT "\t{ 0L, 0, 0, 0, 0 }, \t// 0 (no class)\n"; } my $c = $className; $c =~ s/::/__/g; my $xcallFunc = "xcall_$c"; my $xenumFunc = "0"; $xenumFunc = "xenum_$c" if exists $enumclasslist{$className}; # %classinherit needs Foo__Bar, not Foo::Bar? die "problem with $className" unless defined $classinherit{$c}; my $xClassFlags = 0; $xClassFlags =~ s/0\|//; # beautify print OUT "\t{ \"$className\", $classinherit{$c}, $xcallFunc, $xenumFunc, $xClassFlags }, \t//$classidx{$className}\n"; } ); print OUT "};\n\n"; print OUT "// List of all types needed by the methods (arguments and return values)\n"; print OUT "// Name, class ID if arg is a class, and TypeId\n"; print OUT "static Smoke::Type ${libname}_types[] = {\n"; my $typeCount = 0; $allTypes{''}{index} = 0; # We need an "item 0" for my $type (sort keys %allTypes) { $allTypes{$type}{index} = $typeCount; # Register proper index in allTypes if ( $typeCount == 0 ) { print OUT "\t{ 0, 0, 0 },\t//0 (no type)\n"; $typeCount++; next; } my $isEnum = $allTypes{$type}{isEnum}; my $typeId; my $typeFlags = $allTypes{$type}{typeFlags}; my $realType = $allTypes{$type}{realType}; die "$type" if !defined $typeFlags; die "$realType" if $realType =~ /\(/; # First write the name print OUT "\t{ \"$type\", "; # Then write the classId (and find out the typeid at the same time) if(exists $classidx{$realType}) { # this one first, we want t_class for TQBlah* $typeId = 't_class'; print OUT "$classidx{$realType}, "; } elsif($type =~ /&$/ || $type =~ /\*$/) { $typeId = 't_voidp'; print OUT "0, "; # no classId } elsif($isEnum || $allTypes{$realType}{isEnum}) { $typeId = 't_enum'; if($realType =~ /(.*)::/) { my $c = $1; if($classidx{$c}) { print OUT "$classidx{$c}, "; } else { print OUT "0 /* unknown class $c */, "; } } else { print OUT "0 /* unknown $realType */, "; # no classId } } else { $typeId = $typeunion{$realType}; if (defined $typeId) { $typeId =~ s/s_/t_/; # from s_short to t_short for instance } else { # Not a known class - ouch, this happens quite a lot # (private classes, typedefs, template-based types, etc) if ( $skippedClasses{$realType} ) { # print STDERR "$realType has been skipped, using t_voidp for it\n"; } else { unless( $realType =~ / map to a void * } print OUT "0, "; # no classId } # Then write the flags die "$type" if !defined $typeId; print OUT "Smoke::$typeId | $typeFlags },"; print OUT "\t//$typeCount\n"; $typeCount++; # Remember it for coerce_type $allTypes{$type}{typeId} = $typeId; } close OUT; } 1;