From ce4a32fe52ef09d8f5ff1dd22c001110902b60a2 Mon Sep 17 00:00:00 2001 From: toma Date: Wed, 25 Nov 2009 17:56:58 +0000 Subject: 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 --- dcop/dcopidlng/Ast.pm | 51 + dcop/dcopidlng/Iter.pm | 532 +++++++++++ dcop/dcopidlng/Makefile.am | 8 + dcop/dcopidlng/dcopidlng | 15 + dcop/dcopidlng/kalyptus | 1612 ++++++++++++++++++++++++++++++++ dcop/dcopidlng/kalyptusCxxToDcopIDL.pm | 213 +++++ dcop/dcopidlng/kdocAstUtil.pm | 536 +++++++++++ dcop/dcopidlng/kdocParseDoc.pm | 419 +++++++++ dcop/dcopidlng/kdocUtil.pm | 189 ++++ dcop/dcopidlng/run_test.sh | 14 + 10 files changed, 3589 insertions(+) create mode 100644 dcop/dcopidlng/Ast.pm create mode 100644 dcop/dcopidlng/Iter.pm create mode 100644 dcop/dcopidlng/Makefile.am create mode 100755 dcop/dcopidlng/dcopidlng create mode 100644 dcop/dcopidlng/kalyptus create mode 100644 dcop/dcopidlng/kalyptusCxxToDcopIDL.pm create mode 100644 dcop/dcopidlng/kdocAstUtil.pm create mode 100644 dcop/dcopidlng/kdocParseDoc.pm create mode 100644 dcop/dcopidlng/kdocUtil.pm create mode 100755 dcop/dcopidlng/run_test.sh (limited to 'dcop/dcopidlng') diff --git a/dcop/dcopidlng/Ast.pm b/dcop/dcopidlng/Ast.pm new file mode 100644 index 000000000..65af89e63 --- /dev/null +++ b/dcop/dcopidlng/Ast.pm @@ -0,0 +1,51 @@ +package Ast; +use strict; + +use vars qw/ $this $pack @endCodes /; + +#----------------------------------------------------------------------------- +# This package is used to create a simple Abstract Syntax tree. Each node +# in the AST is an associative array and supports two kinds of properties - +# scalars and lists of scalars. +# See SchemParser.pm for an example of usage. +# ... Sriram +#----------------------------------------------------------------------------- + +# Constructor +# e.g AST::New ("personnel") +# Stores the argument in a property called astNodeName whose sole purpose +# is to support Print() + +sub New { + my ($this) = {"astNodeName" => $_[0]}; + bless ($this); + return $this; +} + +# Add a property to this object +# $astNode->AddProp("className", "Employee"); + +sub AddProp { + my ($this) = $_[0]; + $this->{$_[1]} = $_[2]; +} + +# Equivalent to AddProp, except the property name is associated +# with a list of values +# $classAstNode->AddProp("attrList", $attrAstNode); + +sub AddPropList { + my ($this) = $_[0]; + if (! exists $this->{$_[1]}) { + $this->{$_[1]} = []; + } + push (@{$this->{$_[1]}}, $_[2]); +} + +# Returns a list of all the property names of this object +sub GetProps { + my ($this) = $_[0]; + return keys %{$this}; +} + +1; diff --git a/dcop/dcopidlng/Iter.pm b/dcop/dcopidlng/Iter.pm new file mode 100644 index 000000000..7279a6faf --- /dev/null +++ b/dcop/dcopidlng/Iter.pm @@ -0,0 +1,532 @@ +package Iter; + +=head1 Iterator Module + +A set of iterator functions for traversing the various trees and indexes. +Each iterator expects closures that operate on the elements in the iterated +data structure. + + +=head2 Generic + + Params: $node, &$loopsub, &$skipsub, &$applysub, &$recursesub + +Iterate over $node\'s children. For each iteration: + +If loopsub( $node, $kid ) returns false, the loop is terminated. +If skipsub( $node, $kid ) returns true, the element is skipped. + +Applysub( $node, $kid ) is called +If recursesub( $node, $kid ) returns true, the function recurses into +the current node. + +=cut + +sub Generic +{ + my ( $root, $loopcond, $skipcond, $applysub, $recursecond ) = @_; + + return sub { + foreach my $node ( @{$root->{Kids}} ) { + + if ( defined $loopcond ) { + return 0 unless $loopcond->( $root, $node ); + } + + if ( defined $skipcond ) { + next if $skipcond->( $root, $node ); + } + + my $ret = $applysub->( $root, $node ); + return $ret if defined $ret && $ret; + + if ( defined $recursecond + && $recursecond->( $root, $node ) ) { + $ret = Generic( $node, $loopcond, $skipcond, + $applysub, $recursecond)->(); + if ( $ret ) { + return $ret; + } + } + } + + return 0; + }; +} + +sub Class +{ + my ( $root, $applysub, $recurse ) = @_; + + return Generic( $root, undef, + sub { + return !( $node->{NodeType} eq "class" + || $node->{NodeType} eq "struct" ); + }, + $applysub, $recurse ); +} + +=head2 Tree + + Params: $root, $recurse?, $commonsub, $compoundsub, $membersub, + $skipsub + +Traverse the ast tree starting at $root, skipping if skipsub returns true. + +Applying $commonsub( $node, $kid), +then $compoundsub( $node, $kid ) or $membersub( $node, $kid ) depending on +the Compound flag of the node. + +=cut + +sub Tree +{ + my ( $rootnode, $recurse, $commonsub, $compoundsub, $membersub, + $skipsub ) = @_; + + my $recsub = $recurse ? sub { return 1 if $_[1]->{Compound}; } + : undef; + + Generic( $rootnode, undef, $skipsub, + sub { # apply + my ( $root, $node ) = @_; + my $ret; + + if ( defined $commonsub ) { + $ret = $commonsub->( $root, $node ); + return $ret if defined $ret; + } + + if ( $node->{Compound} && defined $compoundsub ) { + $ret = $compoundsub->( $root, $node ); + return $ret if defined $ret; + } + + if( !$node->{Compound} && defined $membersub ) { + $ret = $membersub->( $root, $node ); + return $ret if defined $ret; + } + return; + }, + $recsub # skip + )->(); +} + +=head2 LocalCompounds + +Apply $compoundsub( $node ) to all locally defined compound nodes +(ie nodes that are not external to the library being processed). + +=cut + +sub LocalCompounds +{ + my ( $rootnode, $compoundsub ) = @_; + + return unless defined $rootnode && defined $rootnode->{Kids}; + + foreach my $kid ( sort { $a->{astNodeName} cmp $b->{astNodeName} } + @{$rootnode->{Kids}} ) { + next if !defined $kid->{Compound}; + + $compoundsub->( $kid ) unless defined $kid->{ExtSource}; + LocalCompounds( $kid, $compoundsub ); + } +} + +=head2 Hierarchy + + Params: $node, $levelDownSub, $printSub, $levelUpSub + +This allows easy hierarchy traversal and printing. + +Traverses the inheritance hierarchy starting at $node, calling printsub +for each node. When recursing downward into the tree, $levelDownSub($node) is +called, the recursion takes place, and $levelUpSub is called when the +recursion call is completed. + +=cut + +sub Hierarchy +{ + my ( $node, $ldownsub, $printsub, $lupsub, $nokidssub ) = @_; + + return if defined $node->{ExtSource} + && (!defined $node->{InBy} + || !kdocAstUtil::hasLocalInheritor( $node )); + + $printsub->( $node ); + + if ( defined $node->{InBy} ) { + $ldownsub->( $node ); + + foreach my $kid ( + sort {$a->{astNodeName} cmp $b->{astNodeName}} + @{ $node->{InBy} } ) { + Hierarchy( $kid, $ldownsub, $printsub, $lupsub ); + } + + $lupsub->( $node ); + } + elsif ( defined $nokidssub ) { + $nokidssub->( $node ); + } + + return; +} + +=head2 + + Call $printsub for each *direct* ancestor of $node. + Only multiple inheritance can lead to $printsub being called more than once. + +=cut +sub Ancestors +{ + my ( $node, $rootnode, $noancessub, $startsub, $printsub, + $endsub ) = @_; + my @anlist = (); + + return if $node eq $rootnode; + + if ( !exists $node->{InList} ) { + $noancessub->( $node ) unless !defined $noancessub; + return; + } + + foreach my $innode ( @{ $node->{InList} } ) { + my $nref = $innode->{Node}; # real ancestor + next if defined $nref && $nref == $rootnode; + + push @anlist, $innode; + } + + if ( $#anlist < 0 ) { + $noancessub->( $node ) unless !defined $noancessub; + return; + } + + $startsub->( $node ) unless !defined $startsub; + + foreach my $innode ( sort { $a->{astNodeName} cmp $b->{astNodeName} } + @anlist ) { + + # print + $printsub->( $innode->{Node}, $innode->{astNodeName}, + $innode->{Type}, $innode->{TmplType} ) + unless !defined $printsub; + } + + $endsub->( $node ) unless !defined $endsub; + + return; + +} + +sub Descendants +{ + my ( $node, $nodescsub, $startsub, $printsub, $endsub ) = @_; + + if ( !exists $node->{InBy} ) { + $nodescsub->( $node ) unless !defined $nodescsub; + return; + } + + + my @desclist = (); + DescendantList( \@desclist, $node ); + + if ( $#desclist < 0 ) { + $nodescsub->( $node ) unless !defined $nodescsub; + return; + } + + $startsub->( $node ) unless !defined $startsub; + + foreach my $innode ( sort { $a->{astNodeName} cmp $b->{astNodeName} } + @desclist ) { + + $printsub->( $innode) + unless !defined $printsub; + } + + $endsub->( $node ) unless !defined $endsub; + + return; + +} + +sub DescendantList +{ + my ( $list, $node ) = @_; + + return unless exists $node->{InBy}; + + foreach my $kid ( @{ $node->{InBy} } ) { + push @$list, $kid; + DescendantList( $list, $kid ); + } +} + +=head2 DocTree + +=cut + +sub DocTree +{ + my ( $rootnode, $allowforward, $recurse, + $commonsub, $compoundsub, $membersub ) = @_; + + Generic( $rootnode, undef, + sub { # skip + my( $node, $kid ) = @_; + + unless (!(defined $kid->{ExtSource}) + && ($allowforward || $kid->{NodeType} ne "Forward") + && ($main::doPrivate || !($kid->{Access} =~ /private/)) + && exists $kid->{DocNode} ) { + + return 1; + } + + return; + }, + sub { # apply + my ( $root, $node ) = @_; + + my $ret; + + if ( defined $commonsub ) { + $ret = $commonsub->( $root, $node ); + return $ret if defined $ret; + } + + if ( $node->{Compound} && defined $compoundsub ) { + $ret = $compoundsub->( $root, $node ); + return $ret if defined $ret; + } + elsif( defined $membersub ) { + $ret = $membersub->( $root, $node ); + return $ret if defined $ret; + } + + return; + }, + sub { return 1 if $recurse; return; } # recurse + )->(); + +} + +sub MembersByType +{ + my ( $node, $startgrpsub, $methodsub, $endgrpsub, $nokidssub ) = @_; + +# public + # types + # data + # methods + # signals + # slots + # static +# protected +# private (if enabled) + + if ( !defined $node->{Kids} ) { + $nokidssub->( $node ) if defined $nokidssub; + return; + } + + foreach my $acc ( qw/public protected private/ ) { + next if $acc eq "private" && !$main::doPrivate; + $access = $acc; + + my @types = (); + my @data = (); + my @signals = (); + my @k_dcops = (); + my @k_dcop_signals = (); + my @k_dcop_hiddens = (); + my @slots =(); + my @methods = (); + my @static = (); + my @modules = (); + my @interfaces = (); + + # Build lists + foreach my $kid ( @{$node->{Kids}} ) { + next unless ( $kid->{Access} =~ /$access/ + && !$kid->{ExtSource}) + || ( $access eq "public" + && ( $kid->{Access} eq "signals" + || $kid->{Access} =~ "k_dcop" # note the =~ + || $kid->{Access} eq "K_DCOP")); + + my $type = $kid->{NodeType}; + + if ( $type eq "method" ) { + if ( $kid->{Flags} =~ "s" ) { + push @static, $kid; + } + elsif ( $kid->{Flags} =~ "l" ) { + push @slots, $kid; + } + elsif ( $kid->{Flags} =~ "n" ) { + push @signals, $kid; + } + elsif ( $kid->{Flags} =~ "d" ) { + push @k_dcops, $kid; + } + elsif ( $kid->{Flags} =~ "z" ) { + push @k_dcop_signals, $kid; + } + elsif ( $kid->{Flags} =~ "y" ) { + push @k_dcop_hiddens, $kid; + } + else { + push @methods, $kid; } + } + elsif ( $kid->{Compound} ) { + if ( $type eq "module" ) { + push @modules, $kid; + } + elsif ( $type eq "interface" ) { + push @interfaces, $kid; + } + else { + push @types, $kid; + } + } + elsif ( $type eq "typedef" || $type eq "enum" ) { + push @types, $kid; + } + else { + push @data, $kid; + } + } + + # apply + $uc_access = ucfirst( $access ); + + doGroup( "$uc_access Types", $node, \@types, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "Modules", $node, \@modules, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "Interfaces", $node, \@interfaces, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "$uc_access Methods", $node, \@methods, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "$uc_access Slots", $node, \@slots, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "Signals", $node, \@signals, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "k_dcop", $node, \@k_dcops, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "k_dcop_signals", $node, \@k_dcop_signals, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "k_dcop_hiddens", $node, \@k_dcop_hiddens, $startgrpsub, + $methodsub, $endgrpsub); + doGroup( "$uc_access Static Methods", $node, \@static, + $startgrpsub, $methodsub, $endgrpsub); + doGroup( "$uc_access Members", $node, \@data, $startgrpsub, + $methodsub, $endgrpsub); + } +} + +sub doGroup +{ + my ( $name, $node, $list, $startgrpsub, $methodsub, $endgrpsub ) = @_; + + my ( $hasMembers ) = 0; + foreach my $kid ( @$list ) { + if ( !exists $kid->{DocNode}->{Reimplemented} ) { + $hasMembers = 1; + break; + } + } + return if !$hasMembers; + + if ( defined $methodsub ) { + foreach my $kid ( @$list ) { + if ( !exists $kid->{DocNode}->{Reimplemented} ) { + $methodsub->( $node, $kid ); + } + } + } + + $endgrpsub->( $name ) if defined $endgrpsub; +} + +sub ByGroupLogical +{ + my ( $root, $startgrpsub, $itemsub, $endgrpsub ) = @_; + + return 0 unless defined $root->{Groups}; + + foreach my $groupname ( sort keys %{$root->{Groups}} ) { + next if $groupname eq "astNodeName"||$groupname eq "NodeType"; + + my $group = $root->{Groups}->{ $group }; + next unless $group->{Kids}; + + $startgrpsub->( $group->{astNodeName}, $group->{Desc} ); + + foreach my $kid (sort {$a->{astNodeName} cmp $b->{astNodeName}} + @group->{Kids} ) { + $itemsub->( $root, $kid ); + } + $endgrpsub->( $group->{Desc} ); + } + + return 1; +} + +sub SeeAlso +{ + my ( $node, $nonesub, $startsub, $printsub, $endsub ) = @_; + + if( !defined $node ) { + $nonesub->(); + return; + } + + my $doc = $node; + + if ( $node->{NodeType} ne "DocNode" ) { + $doc = $node->{DocNode}; + if ( !defined $doc ) { + $nonesub->() if defined $nonesub; + return; + } + } + + if ( !defined $doc->{See} ) { + $nonesub->() if defined $nonesub; + return; + } + + my $see = $doc->{See}; + my $ref = $doc->{SeeRef}; + + if ( $#$see < 1 ) { + $nonesub->() if defined $nonesub; + return; + } + + $startsub->( $node ) if defined $startsub; + + for my $i ( 0..$#$see ) { + my $seelabel = $see->[ $i ]; + my $seenode = undef; + if ( defined $ref ) { + $seenode = $ref->[ $i ]; + } + + $printsub->( $seelabel, $seenode ) if defined $printsub; + } + + $endsub->( $node ) if defined $endsub; + + return; +} + +1; diff --git a/dcop/dcopidlng/Makefile.am b/dcop/dcopidlng/Makefile.am new file mode 100644 index 000000000..69aefdac2 --- /dev/null +++ b/dcop/dcopidlng/Makefile.am @@ -0,0 +1,8 @@ +bin_SCRIPTS = dcopidlng + +dcopidlnglib_DATA = Ast.pm Iter.pm kalyptusCxxToDcopIDL.pm kdocAstUtil.pm kdocParseDoc.pm kdocUtil.pm +dcopidlnglib_SCRIPTS = kalyptus +dcopidlnglibdir = $(kde_datadir)/dcopidlng + +check-local: + $(srcdir)/run_test.sh $(srcdir) diff --git a/dcop/dcopidlng/dcopidlng b/dcop/dcopidlng/dcopidlng new file mode 100755 index 000000000..073614242 --- /dev/null +++ b/dcop/dcopidlng/dcopidlng @@ -0,0 +1,15 @@ +#!/bin/sh + +trap "rm -f dcopidlng.stderr.$$" 0 1 2 15 + +if test -z "$KDECONFIG"; then + KDECONFIG=kde-config +fi +LIBDIR="`$KDECONFIG --install data --expandvars`/dcopidlng" +perl -I"$LIBDIR" "$LIBDIR/kalyptus" --allow_k_dcop_accessors -f dcopidl $1 2> dcopidlng.stderr.$$ +RET=$? +if [ $RET -ne 0 ] +then + cat dcopidlng.stderr.$$ >&2 +fi +exit $RET diff --git a/dcop/dcopidlng/kalyptus b/dcop/dcopidlng/kalyptus new file mode 100644 index 000000000..9a3709fc0 --- /dev/null +++ b/dcop/dcopidlng/kalyptus @@ -0,0 +1,1612 @@ +#!/usr/bin/perl -I/Users/duke/src/kde/kdebindings/kalyptus +# -*- indent-tabs-mode: t; c-basic-offset: 4; tab-width: 4 -*- + +# KDOC -- C++ and CORBA IDL interface documentation tool. +# Sirtaj Singh Kang , Jan 1999. +# $Id$ + +# All files in this project are distributed under the GNU General +# Public License. This is Free Software. + +require 5.000; + +use Carp; +use Getopt::Long; +use File::Basename; +use strict; + +use Ast; + +use kdocUtil; +use kdocAstUtil; +use kdocParseDoc; + +use vars qw/ %rootNodes $declNodeType @includes_list %options @formats_wanted $allow_k_dcop_accessors + $skipInternal %defines $defines $match_qt_defines + $libname $outputdir $parse_global_space $striphpath $doPrivate $readstdin + $Version $quiet $debug $debuggen $parseonly $currentfile $cSourceNode $exe + %formats %flagnames @allowed_k_dcop_accesors $allowed_k_dcop_accesors_re $rootNode + @classStack $cNode $globalSpaceClassName + $lastLine $docNode @includes $cpp $defcppcmd $cppcmd $docincluded + $inExtern $inNamespace %stats %definitions @inputqueue @codeqobject /; + +## globals + +%rootNodes = (); # root nodes for each file type +$declNodeType = undef; # last declaration type + +@includes_list = (); # list of files included from the parsed .h + +# All options + +%options = (); # hash of options (set getopt below) +@formats_wanted = (); + +$libname = ""; +$outputdir = "."; + +$striphpath = 0; + +$doPrivate = 0; +$Version = "0.9"; + +$quiet = 0; +$debug = 0; +$debuggen = 0; +$parseonly = 0; +$globalSpaceClassName = "QGlobalSpace"; + +$currentfile = ""; + +$cpp = 0; +$defcppcmd = "g++ -Wp,-C -E"; +$cppcmd = ""; + +$exe = basename $0; + +@inputqueue = (); +@codeqobject = split "\n", < "kalyptusCxxToDcopIDL" ); + +# these are for expansion of method flags +%flagnames = ( v => 'virtual', 's' => 'static', p => 'pure', + c => 'const', l => 'slot', i => 'inline', n => 'signal', + d => 'k_dcop', z => 'k_dcop_signals', y => 'k_dcop_hidden' ); + +@allowed_k_dcop_accesors = qw(k_dcop k_dcop_hidden k_dcop_signals); +$allowed_k_dcop_accesors_re = join("|", @allowed_k_dcop_accesors); + +%definitions = { + _STYLE_CDE => '', + _STYLE_MOTIF => '', + _STYLE_MOTIF_PLUS => '', + PLUS => '', + _STYLE_PLATINUM => '', + _STYLE_SGI => '', + _STYLE_WINDOWS => '', + QT_STATIC_CONST => 'static const', + Q_EXPORT => '', + Q_REFCOUNT => '', + QM_EXPORT_CANVAS => '', + QM_EXPORT_DNS => '', + QM_EXPORT_ICONVIEW => '', + QM_EXPORT_NETWORK => '', + QM_EXPORT_SQL => '', + QM_EXPORT_WORKSPACE => '', + QT_NO_REMOTE => 'QT_NO_REMOTE', + QT_ACCESSIBILITY_SUPPORT => 'QT_ACCESSIBILITY_SUPPORT', + Q_WS_X11 => 'Q_WS_X11', + Q_DISABLE_COPY => 'Q_DISABLE_COPY', + Q_WS_QWS => 'undef', + Q_WS_MAC => 'undef', + Q_OBJECT => <<'CODE', +public: + virtual QMetaObject *metaObject() const; + virtual const char *className() const; + virtual bool qt_invoke( int, QUObject* ); + virtual bool qt_emit( int, QUObject* ); + static QString tr( const char *, const char * = 0 ); + static QString trUtf8( const char *, const char * = 0 ); +private: +CODE +}; + +=head1 KDOC -- Source documentation tool + + Sirtaj Singh Kang , Dec 1998. + +=cut + +# read options + +Getopt::Long::config qw( no_ignore_case permute bundling auto_abbrev ); + +GetOptions( \%options, + "format|f=s", \@formats_wanted, + "url|u=s", + "skip-internal", \$skipInternal, + "skip-deprecated|e", + "document-all|a", + "compress|z", + # HTML options + "html-cols=i", + "html-logo=s", + + "strip-h-path", \$striphpath, + "outputdir|d=s", \$outputdir, + "stdin|i", \$readstdin, + "name|n=s", \$libname, + "version|v|V", \&show_version, + "private|p", \$doPrivate, + "globspace", \$parse_global_space, + "allow_k_dcop_accessors", \$allow_k_dcop_accessors, + + "cpp|P", \$cpp, + "docincluded", \$docincluded, + "cppcmd|C=s", \$cppcmd, + "includedir|I=s", \@includes, + "define=s", \%defines, # define a single preprocessing symbol + "defines=s", \$defines, # file containing preprocessing symbols, one per line + + "quiet|q", \$quiet, + "debug|D", \$debug, # debug the parsing + "debuggen", \$debuggen, # debug the file generation + "parse-only", \$parseonly ) + || exit 1; + +$| = 1 if $debug or $debuggen; + +# preprocessor settings + +if ( $cppcmd eq "" ) { + $cppcmd = $defcppcmd; +} +else { + $cpp = 1; +} + +if ( $#includes >= 0 && !$cpp ) { + die "$exe: --includedir requires --cpp\n"; +} + +# Check output formats. HTML is the default +if( $#formats_wanted < 0 ) { + push @formats_wanted, "java"; +} + +foreach my $format ( @formats_wanted ) { + die "$exe: unsupported format '$format'.\n" + if !defined $formats{$format}; +} + +if( $defines ) +{ + open( DEFS, $defines ) or die "Couldn't open $defines: $!\n"; + my @defs = ; + chomp @defs; + close DEFS; + foreach (@defs) + { + $defines{ $_ } = 1 unless exists $defines{ $_ }; + } +} + +# Check the %defines hash for QT_* symbols and compile the corresponding RE +# Otherwise, compile the default ones. Used for filtering in readCxxLine. +if ( my @qt_defines = map { ($_=~m/^QT_(.*)/)[0] } keys %defines) +{ + my $regexp = "m/^#\\s*ifn?def\\s+QT_(?:" . join('|', map { "\$qt_defines[$_]" } 0..$#qt_defines).")/o"; + $match_qt_defines = eval "sub { my \$s=shift; + \$s=~/^#\\s*if(n)?def/ || return 0; + if(!\$1) { return \$s=~$regexp ? 0:1 } + else { return \$s=~$regexp ? 1:0 } + }"; + die if $@; +} +else +{ + $match_qt_defines = eval q£ + sub + { + my $s = shift; + $s =~ m/^\#\s*ifndef\s+QT_NO_(?:REMOTE| # not in the default compile options + NIS| # ... + XINERAMA| + IMAGEIO_(?:MNG|JPEG)| + STYLE_(?:MAC|INTERLACE|COMPACT) + )/x; + } + £; + die if $@; +} +# Check if there any files to process. +# We do it here to prevent the libraries being loaded up first. + +checkFileArgs(); + +###### +###### main program +###### + parseFiles(); + + if ( $parseonly ) { + print "\n\tParse Tree\n\t------------\n\n"; + kdocAstUtil::dumpAst( $rootNode ); + } + else { + writeDocumentation(); + } + + kdocAstUtil::printDebugStats() if $debug; + + exit 0; +###### + +sub checkFileArgs +{ + return unless $#ARGV < 0; + + die "$exe: no input files.\n" unless $readstdin; + + # read filenames from standard input + while () { + chop; + $_ =~ s,\\,/,g; # back to fwd slash (for Windows) + foreach my $file ( split( /\s+/, $_ ) ) { + push @ARGV, $file; + } + } +} + +sub parseFiles +{ + foreach $currentfile ( @ARGV ) { + my $lang = "CXX"; + + if ( $currentfile =~ /\.idl\s*$/ ) { + # IDL file + $lang = "IDL"; + } + + # assume cxx file + if( $cpp ) { + # pass through preprocessor + my $cmd = $cppcmd; + foreach my $dir ( @includes ) { + $cmd .= " -I $dir "; + } + + $cmd .= " -DQOBJECTDEFS_H $currentfile"; + + open( INPUT, "$cmd |" ) + || croak "Can't preprocess $currentfile"; + } + else { + open( INPUT, "$currentfile" ) + || croak "Can't read from $currentfile"; + } + + print STDERR "$exe: processing $currentfile\n" unless $quiet; + + # reset vars + $rootNode = getRoot( $lang ); + + + # add to file lookup table + my $showname = $striphpath ? basename( $currentfile ) + : $currentfile; + $cSourceNode = Ast::New( $showname ); + $cSourceNode->AddProp( "NodeType", "source" ); + $cSourceNode->AddProp( "Path", $currentfile ); + $rootNode->AddPropList( "Sources", $cSourceNode ); + + # reset state + @classStack = (); + $cNode = $rootNode; + $inExtern = 0; + $inNamespace = 0; + + # parse + my $k = undef; + while ( defined ($k = readDecl()) ) { + print "\nDecl: <$k>[$declNodeType]\n" if $debug; + if( identifyDecl( $k ) && $k =~ /{/ ) { + readCxxCodeBlock(); + } + } + close INPUT; + } +} + + +sub writeDocumentation +{ + foreach my $node ( values %rootNodes ) { + # postprocess + kdocAstUtil::makeInherit( $node, $node ); + + # write + no strict "refs"; + foreach my $format ( @formats_wanted ) { + my $pack = $formats{ $format }; + require $pack.".pm"; + + print STDERR "Generating bindings for $format ", + "language...\n" if $debug; + + my $f = "$pack\::writeDoc"; + &$f( $libname, $node, $outputdir, \%options ); + } + } +} + +###### Parser routines + +=head2 readSourceLine + + Returns a raw line read from the current input file. + This is used by routines outside main, since I don t know + how to share fds. + +=cut + +sub readSourceLine +{ + return ; +} + +=head2 readCxxLine + + Reads a C++ source line, skipping comments, blank lines, + preprocessor tokens and the Q_OBJECT macro + +=cut + +sub readCxxLine +{ + my( $p ); + my( $l ); + + while( 1 ) { + $p = shift @inputqueue || ; + return undef if !defined ($p); + + $p =~ s#//.*$##g; # C++ comment + $p =~ s#/\*(?!\*).*?\*/##g; # C comment + + # join all multiline comments + if( $p =~ m#/\*(?!\*)#s ) { + # unterminated comment +LOOP: + while( defined ($l = ) ) { + $l =~ s#//.*$##g; # C++ comment + $p .= $l; + $p =~ s#/\*(?!\*).*?\*/##sg; # C comment + last LOOP unless $p =~ m#(/\*(?!\*))|(\*/)#sg; + } + } + + if ( $p =~ /^\s*Q_OBJECT/ ) { + push @inputqueue, @codeqobject; + next; + } + # Hack, waiting for real handling of preprocessor defines + $p =~ s/QT_STATIC_CONST/static const/; + $p =~ s/KSVG_GET/KJS::Value get();/; + $p =~ s/KSVG_BASECLASS_GET/KJS::Value get();/; + $p =~ s/KSVG_BRIDGE/KJS::ObjectImp *bridge();/; + $p =~ s/KSVG_FORWARDGET/KJS::Value getforward();/; + $p =~ s/KSVG_PUT/bool put();/; + $p =~ s/KSVG_FORWARDPUT/bool putforward();/; + $p =~ s/KSVG_BASECLASS/virtual KJS::Value cache();/; + if ( $p =~ m/KSVG_DEFINE_PROTOTYPE\((\w+)\)/ ) { + push @inputqueue, split('\n',"namespace KSVG {\nclass $1 {\n};\n};"); + } + + next if ( $p =~ /^\s*$/s ); # blank lines +# || $p =~ /^\s*Q_OBJECT/ # QObject macro +# ); +# + + next if ( $p =~ /^\s*Q_ENUMS/ # ignore Q_ENUMS + || $p =~ /^\s*Q_PROPERTY/ # and Q_PROPERTY + || $p =~ /^\s*Q_OVERRIDE/ # and Q_OVERRIDE + || $p =~ /^\s*Q_SETS/ + || $p =~ /^\s*Q_DUMMY_COMPARISON_OPERATOR/ + || $p =~ /^\s*K_SYCOCATYPE/ # and K_SYCOCA stuff + || $p =~ /^\s*K_SYCOCAFACTORY/ # + || $p =~ /^\s*KSVG_/ # and KSVG stuff ;) + || $p =~ /^\s*KDOM_/ + ); + + push @includes_list, $1 if $p =~ /^#include\s+?\s*$/; + + # remove all preprocessor macros + if( $p =~ /^\s*#\s*(\w+)/ ) { + # Handling of preprocessed sources: skip anything included from + # other files, unless --docincluded was passed. + if (!$docincluded && $p =~ /^\s*#\s*[0-9]+\s*\".*$/ + && not($p =~ /\"$currentfile\"/)) { + # include file markers + while( ) { + last if(/\"$currentfile\"/); + print "Overread $_" if $debug; + }; + print "Cont: $_" if $debug; + } + else { + # Skip platform-specific stuff, or #if 0 stuff + # or #else of something we parsed (e.g. for QKeySequence) + if ( $p =~ m/^#\s*ifdef\s*Q_WS_/ or + $p =~ m/^#\s*if\s+defined\(Q_WS_/ or + $p =~ m/^#\s*if\s+defined\(Q_OS_/ or + $p =~ m/^#\s*if\s+defined\(Q_CC_/ or + $p =~ m/^#\s*if\s+defined\(QT_THREAD_SUPPORT/ or + $p =~ m/^#\s*else/ or + $p =~ m/^#\s*if\s+defined\(Q_FULL_TEMPLATE_INSTANTIATION/ or + $p =~ m/^#\s*ifdef\s+CONTAINER_CUSTOM_WIDGETS/ or + &$match_qt_defines( $p ) or + $p =~ m/^#\s*if\s+0\s+/ ) { + my $if_depth = 1; + while ( defined $p && $if_depth > 0 ) { + $p = ; + last if !defined $p; + $if_depth++ if $p =~ m/^#\s*if/; + $if_depth-- if $p =~ m/^#\s*endif/; + # Exit at #else in the #ifdef QT_NO_ACCEL/#else/#endif case + last if $if_depth == 1 && $p =~ m/^#\s*else\s/; + #ignore elif for now + print "Skipping ifdef'ed line: $p" if $debug; + } + } + + # multiline macros + while ( defined $p && $p =~ m#\\\s*$# ) { + $p = ; + } + } + next; + } + + $lastLine = $p; + return $p; + } +} + +=head2 readCxxCodeBlock + + Reads a C++ code block (recursive curlies), returning the last line + or undef on error. + + Parameters: none + +=cut + +sub readCxxCodeBlock +{ +# Code: begins in a {, ends in }\s*;? +# In between: cxx source, including {} + my ( $count ) = 0; + my $l = undef; + + if ( defined $lastLine ) { + print "lastLine: '$lastLine'" if $debug; + + my $open = kdocUtil::countReg( $lastLine, "{" ); + my $close = kdocUtil::countReg( $lastLine, "}" ); + $count = $open - $close; + + return $lastLine if ( $open || $close) && $count == 0; + } + + # find opening brace + if ( $count == 0 ) { + while( $count == 0 ) { + $l = readCxxLine(); + return undef if !defined $l; + $l =~ s/\\.//g; + $l =~ s/'.?'//g; + $l =~ s/".*?"//g; + + $count += kdocUtil::countReg( $l, "{" ); + print "c ", $count, " at '$l'" if $debug; + } + $count -= kdocUtil::countReg( $l, "}" ); + } + + # find associated closing brace + while ( $count > 0 ) { + $l = readCxxLine(); + croak "Confused by unmatched braces" if !defined $l; + $l =~ s/\\.//g; + $l =~ s/'.?'//g; + $l =~ s/".*?"//g; + + my $add = kdocUtil::countReg( $l, "{" ); + my $sub = kdocUtil::countReg( $l, "}" ); + $count += $add - $sub; + + print "o ", $add, " c ", $sub, " at '$l'" if $debug; + } + + undef $lastLine; + return $l; +} + +=head2 readDecl + + Returns a declaration and sets the $declNodeType variable. + + A decl starts with a type or keyword and ends with [{};] + The entire decl is returned in a single line, sans newlines. + + declNodeType values: undef for error, "a" for access specifier, + "c" for doc comment, "d" for other decls. + + readCxxLine is used to read the declaration. + +=cut + +sub readDecl +{ + undef $declNodeType; + my $l = readCxxLine(); + my ( $decl ) = ""; + + my $allowed_accesors = "private|public|protected|signals"; + $allowed_accesors .= "|$allowed_k_dcop_accesors_re" if $allow_k_dcop_accessors; + + if( !defined $l ) { + return undef; + } + elsif ( $l =~ /^\s*($allowed_accesors) + (\s+\w+)?\s*:/x) { # access specifier + $declNodeType = "a"; + return $l; + } + elsif ( $l =~ /K_DCOP/ ) { + $declNodeType = "k"; + return $l; + } + elsif ( $l =~ m#^\s*/\*\*# ) { # doc comment + $declNodeType = "c"; + return $l; + } + + do { + $decl .= $l; + + if ( $l =~ /[{};]/ ) { + $decl =~ s/\n/ /gs; + $declNodeType = "d"; + return $decl; + } + return undef if !defined ($l = readCxxLine()); + + } while ( 1 ); +} + +#### AST Generator Routines + +=head2 getRoot + + Return a root node for the given type of input file. + +=cut + +sub getRoot +{ + my $type = shift; + carp "getRoot called without type" unless defined $type; + + if ( !exists $rootNodes{ $type } ) { + my $node = Ast::New( "Global" ); # parent of all nodes + $node->AddProp( "NodeType", "root" ); + $node->AddProp( "RootType", $type ); + $node->AddProp( "Compound", 1 ); + $node->AddProp( "KidAccess", "public" ); + + $rootNodes{ $type } = $node; + } + print "getRoot: call for $type\n" if $debug; + + return $rootNodes{ $type }; +} + +=head2 identifyDecl + + Parameters: decl + + Identifies a declaration returned by readDecl. If a code block + needs to be skipped, this subroutine returns a 1, or 0 otherwise. + +=cut + +sub identifyDecl +{ + my( $decl ) = @_; + + my $newNode = undef; + my $skipBlock = 0; + + # Doc comment + if ( $declNodeType eq "c" ) { + $docNode = kdocParseDoc::newDocComment( $decl ); + + # if it's the main doc, it is attached to the root node + if ( defined $docNode->{LibDoc} ) { + kdocParseDoc::attachDoc( $rootNode, $docNode, + $rootNode ); + undef $docNode; + } + + } + elsif ( $declNodeType eq "a" ) { + newAccess( $decl ); + } + elsif ( $declNodeType eq "k" ) { + $cNode->AddProp( "DcopExported", 1 ); + } + + # Typedef struct/class + elsif ( $decl =~ /^\s*typedef + \s+(struct|union|class|enum) + \s*([_\w\:]*) + \s*([;{]) + /xs ) { + my ($type, $name, $endtag, $rest ) = ($1, $2, $3, $' ); + $name = "--" if $name eq ""; + + warn "typedef '$type' n:'$name'\n" if $debug; + + if ( $rest =~ /}\s*([\w_]+(?:::[\w_])*)\s*;/ ) { + # TODO: Doesn't parse members yet! + $endtag = ";"; + $name = $1; + } + + $newNode = newTypedefComp( $type, $name, $endtag ); + } + + # Typedef + elsif ( $decl =~ /^\s*typedef\s+ + (?:typename\s+)? # `typename' keyword + (.*?\s*[\*&]?) # type + \s+([-\w_\:]+) # name + \s*((?:\[[-\w_\:<>\s]*\])*) # array + \s*[{;]\s*$/xs ) { + + print "Typedef: <$1 $3> <$2>\n" if $debug; + $newNode = newTypedef( $1." ".$3, $2 ); + } + + # Enum + elsif ( $decl =~ /^\s*enum\s+([-\w_:]*)?\s*\{(.*)/s ) { + + print "Enum: <$1>\n" if $debug; + my $enumname = defined $2 ? $1 : ""; + + $newNode = newEnum( $enumname ); + } + + # Class/Struct + elsif ( $decl =~ /^\s*((?:template\s*<.*>)?) # 1 template + \s*(class|struct|union|namespace) # 2 struct type + \s*([A-Z_]*EXPORT[A-Z_]*)? # 3 export + (?:\s*Q_PACKED)? + (?:\s*Q_REFCOUNT)? + \s+([\w_]+ # 4 name + (?:<[\w_ :,]+?>)? # maybe explicit template + # (eat chars between <> non-hungry) + (?:::[\w_]+)* # maybe nested + ) + ([^\(]*?) # 5 inheritance + ([;{])/xs ) { # 6 rest + + print "Class: => [$1]\n\t[$2]\n\t[$3]\n\t[$4]\n\t[$5]\n\t[$6]\n" if $debug; + my ( $tmpl, $ntype, $export, $name, $rest, $endtag ) = + ( $1, $2, $3, $4, $5, $6 ); + + if ($ntype eq 'namespace') { + if ($decl =~ /}/) { + return 0; + } + # Set a flag to indicate we're in a multi-line namespace declaration + $inNamespace = 1; + } + + + my @inherits = (); + + $tmpl =~ s/<(.*)>/$1/ if $tmpl ne ""; + + if( $rest =~ /^\s*:\s*/ ) { + # inheritance + $rest = $'; + @inherits = parseInheritance( $rest ); + } + + $newNode = newClass( $tmpl, $ntype, $export, + $name, $endtag, @inherits ); + } + # IDL compound node + elsif( $decl =~ /^\s*(module|interface|exception) # struct type + \s+([-\w_]+) # name + (.*?) # inheritance? + ([;{])/xs ) { + + my ( $type, $name, $rest, $fwd, $complete ) + = ( $1, $2, $3, $4 eq ";" ? 1 : 0, + 0 ); + my @in = (); + print "IDL: [$type] [$name] [$rest] [$fwd]\n" if $debug; + + if( $rest =~ /^\s*:\s*/ ) { + $rest = $'; + $rest =~ s/\s+//g; + @in = split ",", $rest; + } + if( $decl =~ /}\s*;/ ) { + $complete = 1; + } + + $newNode = newIDLstruct( $type, $name, $fwd, $complete, @in ); + } + # Method + elsif ( $decl =~ /^\s*(?:(?:class|struct)\s*)?([^=]+?(?:operator\s*(?:\(\)|.?=)\s*)?) # ret+nm + \( (.*?) \) # parameters + \s*((?:const)?)\s* + (?:throw\s*\(.*?\))? + \s*((?:=\s*0(?:L?))?)\s* # Pureness. is "0L" allowed? + \s*[;{]+/xs ) { # rest + + my $tpn = $1; # type + name + my $params = $2; + # Remove constructor initializer, that's not in the params + if ( $params =~ /\s*\)\s*:\s*/ ) { + # Hack: first .* made non-greedy for QSizePolicy using a?(b):c in ctor init + $params =~ s/(.*?)\s*\)\s*:\s*.*$/$1/; + } + + my $const = $3 eq "" ? 0 : 1; + my $pure = $4 eq "" ? 0 : 1; + $tpn =~ s/\s+/ /g; + $params =~ s/\s+/ /g; + + print "Method: R+N:[$tpn]\n\tP:[$params]\n\t[$const]\n" if $debug; + + if ( $tpn =~ /((?:\w+\s*::\s*)?operator.*?)\s*$/ # operator + || $tpn =~ /((?:\w*\s*::\s*~?)?[-\w:]+)\s*$/ ) { # normal + my $name = $1; + $tpn = $`; + $newNode = newMethod( $tpn, $name, + $params, $const, $pure ); + } + + $skipBlock = 1; # FIXME check end token before doing this! + } + # Using: import namespace + elsif ( $decl =~ /^\s*using\s+namespace\s+(\w+)/ ) { + newNamespace( $1 ); + + } + + # extern block + elsif ( $decl =~ /^\s*extern\s*"(.*)"\s*{/ ) { + $inExtern = 1 unless $decl =~ /}/; + } + + # Single variable + elsif ( $decl =~ /^ + \s*( (?:[\w_:]+(?:\s+[\w_:]+)*? )# type + \s*(?:<.+>)? # template + \s*(?:[\&\*])? # ptr or ref + (?:\s*(?:const|volatile))* ) + \s*([\w_:]+) # name + \s*( (?:\[[^\[\]]*\] (?:\s*\[[^\[\]]*\])*)? ) # array + \s*((?:=.*)?) # value + \s*([;{])\s*$/xs ) { + my $type = $1; + my $name = $2; + my $arr = $3; + my $val = $4; + my $end = $5; + + $type =~ s/\s+/ /g; + + if ( $type !~ /^friend\s+class\s*/ ) { + print "Var: [$name] type: [$type$arr] val: [$val]\n" + if $debug; + + $newNode = newVar( $type.$arr, $name, $val ); + } + + $skipBlock = 1 if $end eq '{'; + } + + # Multi variables + elsif ( $decl =~ m/^ + \s*( (?:[\w_:]+(?:\s+[\w_:]+)*? ) # type + \s*(?:<.+>)?) # template + + \s*( (?:\s*(?: [\&\*][\&\*\s]*)? # ptr or ref + [\w_:]+) # name + \s*(?:\[[^\[\]]*\] (?:\s*\[[^\[\]]*\])*)? # array + \s*(?:, # extra vars + \s*(?: [\&\*][\&\*\s]*)? # ptr or ref + \s*(?:[\w_:]+) # name + \s*(?:\[[^\[\]]*\] (?:\s*\[[^\[\]]*\])*)? # array + )* + \s*(?:=.*)?) # value + \s*[;]/xs ) { + + my $type = $1; + my $names = $2; + my $end = $3; + my $doc = $docNode; + + print "Multivar: type: [$type] names: [$names] \n" if $debug; + + foreach my $vardecl ( split( /\s*,\s*/, $names ) ) { + next unless $vardecl =~ m/ + \s*((?: [\&\*][\&\*\s]*)?) # ptr or ref + \s*([\w_:]+) # name + \s*( (?:\[[^\[\]]*\] (?:\s*\[[^\[\]]*\])*)? ) # array + \s*((?:=.*)?) # value + /xs; + my ($ptr, $name, $arr, $val) = ($1, $2, $3, $4); + + print "Split: type: [$type$ptr$arr] ", + " name: [$name] val: [$val] \n" if $debug; + + my $node = newVar( $type.$ptr.$arr, $name, $val ); + + $docNode = $doc; # reuse docNode for each + postInitNode( $node ) unless !defined $node; + } + + $skipBlock = 1 if $end eq '{'; + } + # end of an "extern" block + elsif ( $decl =~ /^\s*}\s*$/ && $inExtern ) { + $inExtern = 0; + } + # end of an in-block declaration + elsif ( $decl =~ /^\s*}\s*(.*?)\s*;\s*$/ || ($decl =~ /^\s*}\s*$/ && $inNamespace) ) { + + if ( $cNode->{astNodeName} eq "--" ) { + # structure typedefs should have no name preassigned. + # If they do, then the name in + # "typedef struct { ..." is kept instead. + # TODO: Buglet. You should fix YOUR code dammit. ;) + + + $cNode->{astNodeName} = $1; + my $siblings = $cNode->{Parent}->{KidHash}; + undef $siblings->{"--"}; + $siblings->{ $1 } = $cNode; + } + + # C++ namespaces end with a '}', and not '};' like classes + if ($decl =~ /^\s*}\s*$/ ) { + $inNamespace = 0; + } + + if ( $#classStack < 0 ) { + confess "close decl found, but no class in stack!" ; + $cNode = $rootNode; + } + else { + $cNode = pop @classStack; + print "end decl: popped $cNode->{astNodeName}\n" + if $debug; + } + } + # unidentified block start + elsif ( $decl =~ /{/ ) { + print "Unidentified block start: $decl\n" if $debug; + $skipBlock = 1; + } + # explicit template instantiation, or friend template + elsif ( $decl =~ /(template|friend)\s+class\s+(?:Q[A-Z_]*EXPORT[A-Z_]*\s*)?\w+\s*<.*>\s*;/x ) { + # Nothing to be done with those. + } + else { + + ## decl is unidentified. + warn "Unidentified decl: $decl\n"; + } + + # once we get here, the last doc node is already used. + # postInitNode should NOT be called for forward decls + postInitNode( $newNode ) unless !defined $newNode; + + return $skipBlock; +} + +sub postInitNode +{ + my $newNode = shift; + + carp "Cannot postinit undef node." if !defined $newNode; + + # The reasoning here: + # Forward decls never get a source node. + # Once a source node is defined, don't assign another one. + + if ( $newNode->{NodeType} ne "Forward" && !defined $newNode->{Source}) { + $newNode->AddProp( "Source", $cSourceNode ); + } elsif ( $newNode->{NodeType} eq "Forward" ) { + if ($debug) { + print "postInit: skipping fwd: $newNode->{astNodeName}\n"; + } + undef $docNode; + return; + } + + if( defined $docNode ) { + kdocParseDoc::attachDoc( $newNode, $docNode, $rootNode ); + undef $docNode; + } +} + + +##### Node generators + +=head2 newEnum + + Reads the parameters of an enumeration. + + Returns the parameters, or undef on error. + +=cut + +sub newEnum +{ + my ( $enum ) = @_; + my $k = undef; + my $params = ""; + + $k = $lastLine if defined $lastLine; + + if( defined $lastLine && $lastLine =~ /{/ ) { + $params = $'; + if ( $lastLine =~ /}(.*?);/ ) { + return initEnum( $enum, $1, $params ); + } + } + + while ( defined ( $k = readCxxLine() ) ) { + $params .= $k; + + if ( $k =~ /}(.*?);/ ) { + return initEnum( $enum, $1, $params ); + } + } + + return undef; +} + +=head2 initEnum + + Parameters: name, (ref) params + + Returns an initialized enum node. + +=cut + +sub initEnum +{ + my( $name, $end, $params ) = @_; + + ($name = $end) if $name eq "" && $end ne ""; + + $params =~ s#\s+# #sg; # no newlines + $params =~ s#\s*/\*([^\*]/|\*[^/]|[^\*/])*\*/##g; # strip out comments + $params = $1 if $params =~ /^\s*{?(.*)}/; + print "$name params: [$params]\n" if $debug; + + + my ( $node ) = Ast::New( $name ); + $node->AddProp( "NodeType", "enum" ); + $node->AddProp( "Params", $params ); + makeParamList( $node, $params, 1 ); # Adds the ParamList property containing the list of param nodes + kdocAstUtil::attachChild( $cNode, $node ); + + return $node; +} + +=head2 newIDLstruct + + Parameters: type, name, forward, complete, inherits... + + Handles an IDL structure definition (ie module, interface, + exception). + +=cut + +sub newIDLstruct +{ + my ( $type, $name, $fwd, $complete ) = @_; + + my $node = exists $cNode->{KidHash} ? + $cNode->{KidHash}->{ $name } : undef; + + if( !defined $node ) { + $node = Ast::New( $name ); + $node->AddProp( "NodeType", $fwd ? "Forward" : $type ); + $node->AddProp( "KidAccess", "public" ); + $node->AddProp( "Compound", 1 ) unless $fwd; + kdocAstUtil::attachChild( $cNode, $node ); + } + elsif ( $fwd ) { + # If we have a node already, we ignore forwards. + return undef; + } + elsif ( $node->{NodeType} eq "Forward" ) { + # we are defining a previously forward node. + $node->AddProp( "NodeType", $type ); + $node->AddProp( "Compound", 1 ); + $node->AddProp( "Source", $cSourceNode ); + } + + # register ancestors. + foreach my $ances ( splice ( @_, 4 ) ) { + my $n = kdocAstUtil::newInherit( $node, $ances ); + } + + if( !( $fwd || $complete) ) { + print "newIDL: pushing $cNode->{astNodeName},", + " new is $node->{astNodeName}\n" + if $debug; + push @classStack, $cNode; + $cNode = $node; + } + + return $node; +} + +=head2 newClass + + Parameters: tmplArgs, cNodeType, export, name, endTag, @inheritlist + + Handles a class declaration (also fwd decls). + +=cut + +sub newClass +{ + my( $tmplArgs, $cNodeType, $export, $name, $endTag ) = @_; + + my $access = "private"; + $access = "public" if $cNodeType ne "class"; + + # try to find an exisiting node, or create a new one + # We need to make the fully-qualified-name otherwise findRef will look + # for that classname in the global namespace + # testcase: class Foo; namespace Bar { class Foo { ... } } + my @parents; + push @parents, kdocAstUtil::heritage($cNode) if (defined $cNode->{Parent}); + push @parents, $name; + my $fullyQualifiedName = join "::", @parents; + print "looking for $fullyQualifiedName\n" if($debug); + my $oldnode = kdocAstUtil::findRef( $cNode, $fullyQualifiedName ); + my $node = defined $oldnode ? $oldnode : Ast::New( $name ); + + if ( $endTag ne "{" ) { + # forward + if ( !defined $oldnode ) { + # new forward node + $node->AddProp( "NodeType", "Forward" ); + $node->AddProp( "KidAccess", $access ); + print "newClass: Attaching $node->{astNodeName} to $cNode->{astNodeName}\n" if $debug; + kdocAstUtil::attachChild( $cNode, $node ); + } + return $node; + } + + # this is a class declaration + + print "ClassName: $name\n" if $debug; + + $node->AddProp( "NodeType", $cNodeType ); + $node->AddProp( "Compound", 1 ); + $node->AddProp( "Source", $cSourceNode ); + + if ($cNodeType eq 'namespace') { + $node->AddPropList( "Sources", $cSourceNode ); + } + + $node->AddProp( "KidAccess", $access ); + $node->AddProp( "Export", $export ) unless $export eq ""; + $node->AddProp( "Tmpl", $tmplArgs ) unless $tmplArgs eq ""; + + if ( !defined $oldnode ) { + print "newClass: Attaching $node->{astNodeName} to $cNode->{astNodeName}\n" if $debug; + kdocAstUtil::attachChild( $cNode, $node ); + } else { + print "newClass: Already found $node->{astNodeName} in $cNode->{astNodeName}\n" if $debug; + } + + # inheritance + + foreach my $ances ( splice (@_, 5) ) { + my $type = ""; + my $name = $ances; + my $intmpl = undef; + +WORD: + foreach my $word ( split ( /([\w:]+(:?\s*<.*>)?)/, $ances ) ) { + next WORD unless $word =~ /^[\w:]/; + if ( $word =~ /(private|public|protected|virtual)/ ) { + $type .= "$1 "; + } + else { + + if ( $word =~ /<(.*)>/ ) { + # FIXME: Handle multiple tmpl args + $name = $`; + $intmpl = $1; + } + else { + $name = $word; + } + + last WORD; + } + } + + # set inheritance access specifier if none specified + if ( $type eq "" ) { + $type = $cNodeType eq "class" ? "private ":"public "; + } + chop $type; + + # attach inheritance information + my $n = kdocAstUtil::newInherit( $node, $name ); + $n->AddProp( "Type", $type ); + + $n->AddProp( "TmplType", $intmpl ) if defined $intmpl; + + print "In: $name type: $type, tmpl: $intmpl\n" if $debug; + } + + # new current node + print "newClass: Pushing $cNode->{astNodeName}, new current node is $node->{astNodeName}\n" if $debug; + push ( @classStack, $cNode ); + $cNode = $node; + + return $node; +} + + +=head3 parseInheritance + + Param: inheritance decl string + Returns: list of superclasses (template decls included) + + This will fail if < and > appear in strings in the decl. + +=cut + +sub parseInheritance +{ + my $instring = shift; + my @inherits = (); + + my $accum = ""; + foreach $instring ( split (/\s*,\s*/, $instring) ) { + $accum .= $instring.", "; + next unless (kdocUtil::countReg( $accum, "<" ) + - kdocUtil::countReg( $accum, ">" ) ) == 0; + + # matching no. of < and >, so assume the parent is + # complete + $accum =~ s/,\s*$//; + print "Inherits: '$accum'\n" if $debug; + push @inherits, $accum; + $accum = ""; + } + + return @inherits; +} + + +=head2 newNamespace + + Param: namespace name. + Returns nothing. + + Imports a namespace into the current node, for ref searches etc. + Triggered by "using namespace ..." + +=cut + +sub newNamespace +{ + $cNode->AddPropList( "ImpNames", shift ); +} + + + +=head2 newTypedef + + Parameters: realtype, name + + Handles a type definition. + +=cut + +sub newTypedef +{ + my ( $realtype, $name ) = @_; + + my ( $node ) = Ast::New( $name ); + + $node->AddProp( "NodeType", "typedef" ); + $node->AddProp( "Type", $realtype ); + + kdocAstUtil::attachChild( $cNode, $node ); + + return $node; +} + +=head2 newTypedefComp + + Params: realtype, name endtoken + + Creates a new compound type definition. + +=cut + +sub newTypedefComp +{ + my ( $realtype, $name, $endtag ) = @_; + + my ( $node ) = Ast::New( $name ); + + $node->AddProp( "NodeType", "typedef" ); + $node->AddProp( "Type", $realtype ); + + kdocAstUtil::attachChild( $cNode, $node ); + + if ( $endtag eq '{' ) { + print "newTypedefComp: Pushing $cNode->{astNodeName}\n" + if $debug; + push ( @classStack, $cNode ); + $cNode = $node; + } + + return $node; +} + + +=head2 newMethod + + Parameters: retType, name, params, const, pure? + + Handles a new method declaration or definition. + +=cut +BEGIN { + +my $theSourceNode = $cSourceNode; + +sub newMethod +{ + my ( $retType, $name, $params, $const, $pure ) = @_; + my $parent = $cNode; + my $class; + + print "Cracked: [$retType] [$name]\n\t[$params]\n\t[$const]\n" + if $debug; + + if ( $retType =~ /([\w\s_<>,]+)\s*::\s*$/ ) { + # check if stuff before :: got into rettype by mistake. + $retType = $`; + ($name = $1."::".$name); + $name =~ s/\s+/ /g; + print "New name = \"$name\" and type = '$retType'\n" if $debug; + } + + # A 'friend method' declaration isn't a real method declaration + return undef if ( $retType =~ /^friend\s+/ || $retType =~ /^friend\s+class\s+/ ); + + my $isGlobalSpace = 0; + + if( $name =~ /^\s*(.*?)\s*::\s*(.*?)\s*$/ ) { + # Fully qualified method name. + $name = $2; + $class = $1; + + if( $class =~ /^\s*$/ ) { + $parent = $rootNode; + } + elsif ( $class eq $cNode->{astNodeName} ) { + $parent = $cNode; + } + else { + # ALWAYS IGNORE... + return undef; + + my $node = kdocAstUtil::findRef( $cNode, $class ); + + if ( !defined $node ) { + # if we couldn't find the name, try again with + # all template parameters stripped off: + my $strippedClass = $class; + $strippedClass =~ s/<[^<>]*>//g; + + $node = kdocAstUtil::findRef( $cNode, $strippedClass ); + + # if still not found: give up + if ( !defined $node ) { + warn "$exe: Unidentified class: $class ". + "in $currentfile\:$.\n"; + return undef; + } + } + + $parent = $node; + } + } + # TODO fix for $retType =~ /template<.*?>/ + elsif( $parse_global_space && $parent->{NodeType} eq "root" && $name !~ /\s*qt_/ && $retType !~ /template\s*<.*?>/ ) { + $class = $globalSpaceClassName; # FIXME - sanitize the naming system? + $isGlobalSpace = 1; + + my $opsNode = kdocAstUtil::findRef( $cNode, $class ); + if (!$opsNode) { + # manually create a "GlobalSpace" class + $opsNode = Ast::New( $class ); + $opsNode->AddProp( "NodeType", "class" ); + $opsNode->AddProp( "Compound", 1 ); + $opsNode->AddProp( "Source", $cSourceNode ); # dummy + $opsNode->AddProp( "KidAccess", "public" ); + kdocAstUtil::attachChild( $cNode, $opsNode ); + } + # Add a special 'Source' property for methods in global space + $cNode->AddProp( "Source", $theSourceNode ); + unless( $theSourceNode == $cSourceNode ) { + $theSourceNode = $cSourceNode; + $opsNode->AddPropList( "Sources", $theSourceNode ); # sources are scattered across Qt + } + $parent = $opsNode; + } + + # flags + + my $flags = ""; + + if( $retType =~ /static/ || $isGlobalSpace ) { + $flags .= "s"; + $retType =~ s/static//g; + } + + if( $const && !$isGlobalSpace ) { + $flags .= "c"; + } + + if( $pure ) { + $flags .= "p"; + } + + if( $retType =~ /virtual/ ) { + $flags .= "v"; + $retType =~ s/virtual//g; + } + + print "\n" if $flags ne "" && $debug; + + if ( !defined $parent->{KidAccess} ) { + warn "'", $parent->{astNodeName}, "' has no KidAccess ", + exists $parent->{Forward} ? "(forward)\n" :"\n"; + } + + # NB, these are =~, so make sure they are listed in correct order + if ( $parent->{KidAccess} =~ /slot/ ) { + $flags .= "l"; + } + elsif ( $parent->{KidAccess} =~ /k_dcop_signals/ ) { + $flags .= "z"; + } + elsif ( $parent->{KidAccess} =~ /k_dcop_hidden/ ) { + $flags .= "y"; + } + elsif ( $parent->{KidAccess} =~ /k_dcop/ ) { + $flags .= "d"; + } + elsif ( $parent->{KidAccess} =~ /signal/ ) { + $flags .= "n"; + } + + $retType =~ s/QM?_EXPORT[_A-Z]*\s*//; + $retType =~ s/inline\s+//; + $retType =~ s/extern\s+//; + $retType =~ s/^\s*//g; + $retType =~ s/\s*$//g; + $retType =~ s/^class\s/ /; # Remove redundant class forward decln's + $retType =~ s/AddProp( "NodeType", "method" ); + $node->AddProp( "Flags", $flags ); + $node->AddProp( "ReturnType", $retType ); + $node->AddProp( "Params", $params ); # The raw string with the whole param list + makeParamList( $node, $params, 0 ); # Adds the ParamList property containing the list of param nodes + + $parent->AddProp( "Pure", 1 ) if $pure; + + kdocAstUtil::attachChild( $parent, $node ); + return $node; +} + +} + +=head2 makeParamList + + Parameters: + * method (or enum) node + * string containing the whole param list + * 1 for enums + + Adds a property "ParamList" to the method node. + This property contains a list of nodes, one for each parameter. + + Each parameter node has the following properties: + * ArgType the type of the argument, e.g. const QString& + * ArgName the name of the argument - optionnal + * DefaultValue the default value of the argument - optionnal + + For enum values, ArgType is unset, ArgName is the name, DefaultValue its value. + + Author: David Faure +=cut + +sub makeParamList($$$) +{ + my ( $methodNode, $params, $isEnum ) = @_; + $params =~ s/\s+/ /g; # normalize multiple spaces/tabs into a single one + $params =~ s/\s*([\*\&])\s*/$1 /g; # normalize spaces before and after *, & + $params =~ s/\s*(,)([^'\s])\s*/$1 $2/g; # And after ',', but not if inside single quotes + $params =~ s/^\s*void\s*$//; # foo(void) ==> foo() + $params =~ s/^\s*$//; + # Make sure the property always exists, makes iteration over it easier + $methodNode->AddProp( "ParamList", [] ); + + my @args = kdocUtil::splitUnnested( ',', $params); + + my $argId = 0; + foreach my $arg ( @args ) { + my $argType; + my $argName; + my $defaultparam; + $arg =~ s/\s*([^\s].*[^\s])\s*/$1/; # stripWhiteSpace + $arg =~ s/(\w+)\[\]/\* $1/; # Turn [] array into * + $arg =~ s/^class //; # Remove any redundant 'class' forward decln's + + # The RE below reads as: = ( string constant or char or cast to numeric literal + # or some word/number, with optional bitwise shifts, OR'ed or +'ed flags, and/or function call ). + if ( $arg =~ s/\s*=\s*(("[^\"]*")|\([^)]*\)\s*[\+-]?\s*[0-9]+|(\'.\')|(([-\w:~]*)\s*([<>\|\+-]*\s*[\w._]*\s*)*(\([^(]*\))?))// ) { + $defaultparam = $1; + } + + if (defined $defaultparam && $isEnum) { + # Remove any casts in enum values, for example this in kfileitem.h: + # 'enum { Unknown = (mode_t) - 1 };' + $defaultparam =~ s/\([^\)]+\)(.*[0-9].*)/$1/; + } + + # Separate arg type from arg name, if the latter is specified + if ( $arg =~ /(.*)\s+([\w_]+)\s*$/ || $arg =~ /(.*)\(\s*\*\s([\w_]+)\)\s*\((.*)\)\s*$/ ) { + if ( defined $3 ) { # function pointer + $argType = $1."(*)($3)"; + $argName = $2; + } else { + $argType = $1; + $argName = $2; + } + } else { # unnamed arg - or enum value + $argType = $arg if (!$isEnum); + $argName = $arg if ($isEnum); + } + $argId++; + + my $node = Ast::New( $argId ); # let's make the arg index the node "name" + $node->AddProp( "NodeType", "param" ); + $node->AddProp( "ArgType", $argType ); + $node->AddProp( "ArgName", $argName ) if (defined $argName); + $node->AddProp( "DefaultValue", $defaultparam ) if (defined $defaultparam); + $methodNode->AddPropList( "ParamList", $node ); + #print STDERR "ArgType: $argType ArgName: $argName\n" if ($debug); + } +} + +=head2 newAccess + + Parameters: access + + Sets the default "Access" specifier for the current class node. If + the access is a "slot" type, "_slots" is appended to the access + string. + +=cut + +sub newAccess +{ + my ( $access ) = @_; + + return undef unless ($access =~ /^\s*(\w+)\s*(slots|$allowed_k_dcop_accesors_re)?/); + + print "Access: [$1] [$2]\n" if $debug; + + $access = $1; + + if ( defined $2 && $2 ne "" ) { + $access .= "_" . $2; + } + + $cNode->AddProp( "KidAccess", $access ); + + return $cNode; +} + + +=head2 newVar + + Parameters: type, name, value + + New variable. Value is ignored if undef + +=cut + +sub newVar +{ + my ( $type, $name, $val ) = @_; + + my $node = Ast::New( $name ); + $node->AddProp( "NodeType", "var" ); + + my $static = 0; + if ( $type =~ /static/ ) { + # $type =~ s/static//; + $static = 1; + } + + $node->AddProp( "Type", $type ); + $node->AddProp( "Flags", 's' ) if $static; + $node->AddProp( "Value", $val ) if defined $val; + kdocAstUtil::attachChild( $cNode, $node ); + + return $node; +} + + + +=head2 show_version + + Display short version information and quit. + +=cut + +sub show_version +{ + die "$exe: $Version (c) Sirtaj S. Kang \n"; +} 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 : 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 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 "\n"; + + print STDOUT "".@{$rootnode->{Sources}}[0]->{astNodeName}."\n"; + + print STDOUT map { "$_\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 "\n"; + print STDOUT " $className\n"; + print STDOUT " $node->{Export}\n" if ($node->{Export}); + 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. 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=\"&\"" if $x_isRef; + + $argType =~ s/^\s*(.*?)\s*$/$1/; + $argType =~ s//>/g; + $argType =~ s/\s//g; + + $args .= " $argType$arg->{ArgName}\n"; + } + + my $qual = ""; + $qual .= " qual=\"const\"" if $flags =~ "c"; + + $returnType = "void" unless $returnType; + $returnType =~ s//>/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 .= " $returnType\n"; + $methodCode .= " $name\n"; + $methodCode .= "$args"; + $methodCode .= " \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; diff --git a/dcop/dcopidlng/kdocAstUtil.pm b/dcop/dcopidlng/kdocAstUtil.pm new file mode 100644 index 000000000..ec67ace5f --- /dev/null +++ b/dcop/dcopidlng/kdocAstUtil.pm @@ -0,0 +1,536 @@ +=head1 kdocAstUtil + + Utilities for syntax trees. + +=cut + + +package kdocAstUtil; + +use Ast; +use Carp; +use File::Basename; +use kdocUtil; +use Iter; +use strict; + +use vars qw/ $depth $refcalls $refiters @noreflist %noref /; + +sub BEGIN { +# statistics for findRef + + $depth = 0; + $refcalls = 0; + $refiters = 0; + +# findRef will ignore these words + + @noreflist = qw( const int char long double template + unsigned signed float void bool true false uint + uint32 uint64 extern static inline virtual operator ); + + foreach my $r ( @noreflist ) { + $noref{ $r } = 1; + } +} + + +=head2 findRef + + Parameters: root, ident, report-on-fail + Returns: node, or undef + + Given a root node and a fully qualified identifier (:: separated), + this function will try to find a child of the root node that matches + the identifier. + +=cut + +sub findRef +{ + my( $root, $name, $r ) = @_; + + confess "findRef: no name" if !defined $name || $name eq ""; + + $name =~ s/\s+//g; + return undef if exists $noref{ $name }; + + $name =~ s/^#//g; + + my ($iter, @tree) = split /(?:\:\:|#)/, $name; + my $kid; + + $refcalls++; + + # Upward search for the first token + return undef if !defined $iter; + + while ( !defined findIn( $root, $iter ) ) { + return undef if !defined $root->{Parent}; + $root = $root->{Parent}; + } + $root = $root->{KidHash}->{$iter}; + carp if !defined $root; + + # first token found, resolve the rest of the tree downwards + foreach $iter ( @tree ) { + confess "iter in $name is undefined\n" if !defined $iter; + next if $iter =~ /^\s*$/; + + unless ( defined findIn( $root, $iter ) ) { + confess "findRef: failed on '$name' at '$iter'\n" + if defined $r; + return undef; + } + + $root = $root->{KidHash}->{ $iter }; + carp if !defined $root; + } + + return $root; +} + +=head2 findIn + + node, name: search for a child + +=cut + +sub findIn +{ + return undef unless defined $_[0]->{KidHash}; + + my $ret = $_[0]->{KidHash}->{ $_[1] }; + + return $ret; +} + + +# +# Inheritance utilities +# + +=head2 makeInherit + + Parameter: $rootnode, $parentnode + + Make an inheritance graph from the parse tree that begins + at rootnode. parentnode is the node that is the parent of + all base class nodes. + +=cut + +sub makeInherit +{ + my( $rnode, $parent ) = @_; + + foreach my $node ( @{ $rnode->{Kids} } ) { + next if !defined $node->{Compound}; + + # set parent to root if no inheritance + + if ( !exists $node->{InList} ) { + newInherit( $node, "Global", $parent ); + $parent->AddPropList( 'InBy', $node ); + + makeInherit( $node, $parent ); + next; + } + + # link each ancestor + my $acount = 0; +ANITER: + foreach my $in ( @{ $node->{InList} } ) { + unless ( defined $in ) { + Carp::cluck "warning: $node->{astNodeName} " + ." has undef in InList."; + next ANITER; + } + + my $ref = kdocAstUtil::findRef( $rnode, + $in->{astNodeName} ); + + if( !defined $ref ) { + # ancestor undefined + warn "warning: ", $node->{astNodeName}, + " inherits unknown class '", + $in->{astNodeName},"'\n"; + + $parent->AddPropList( 'InBy', $node ); + } + else { + # found ancestor + $in->AddProp( "Node", $ref ); + $ref->AddPropList( 'InBy', $node ); + $acount++; + } + } + + if ( $acount == 0 ) { + # inherits no known class: just parent it to global + newInherit( $node, "Global", $parent ); + $parent->AddPropList( 'InBy', $node ); + } + makeInherit( $node, $parent ); + } +} + +=head2 newInherit + + p: $node, $name, $lnode? + + Add a new ancestor to $node with raw name = $name and + node = lnode. +=cut + +sub newInherit +{ + my ( $node, $name, $link ) = @_; + + my $n = Ast::New( $name ); + $n->AddProp( "Node", $link ) unless !defined $link; + + $node->AddPropList( "InList", $n ); + return $n; +} + +=head2 inheritName + + pr: $inheritance node. + + Returns the name of the inherited node. This checks for existence + of a linked node and will use the "raw" name if it is not found. + +=cut + +sub inheritName +{ + my ( $innode ) = @_; + + return defined $innode->{Node} ? + $innode->{Node}->{astNodeName} + : $innode->{astNodeName}; +} + +=head2 inheritedBy + + Parameters: out listref, node + + Recursively searches for nodes that inherit from this one, returning + a list of inheriting nodes in the list ref. + +=cut + +sub inheritedBy +{ + my ( $list, $node ) = @_; + + return unless exists $node->{InBy}; + + foreach my $kid ( @{ $node->{InBy} } ) { + push @$list, $kid; + inheritedBy( $list, $kid ); + } +} + +=head2 hasLocalInheritor + + Parameter: node + Returns: 0 on fail + + Checks if the node has an inheritor that is defined within the + current library. This is useful for drawing the class hierarchy, + since you don't want to display classes that have no relationship + with classes within this library. + + NOTE: perhaps we should cache the value to reduce recursion on + subsequent calls. + +=cut + +sub hasLocalInheritor +{ + my $node = shift; + + return 0 if !exists $node->{InBy}; + + my $in; + foreach $in ( @{$node->{InBy}} ) { + return 1 if !exists $in->{ExtSource} + || hasLocalInheritor( $in ); + } + + return 0; +} + + + +=head2 allMembers + + Parameters: hashref outlist, node, $type + + Fills the outlist hashref with all the methods of outlist, + recursively traversing the inheritance tree. + + If type is not specified, it is assumed to be "method" + +=cut + +sub allMembers +{ + my ( $outlist, $n, $type ) = @_; + my $in; + $type = "method" if !defined $type; + + if ( exists $n->{InList} ) { + + foreach $in ( @{$n->{InList}} ) { + next if !defined $in->{Node}; + my $i = $in->{Node}; + + allMembers( $outlist, $i ) + unless $i == $main::rootNode; + } + } + + return unless exists $n->{Kids}; + + foreach $in ( @{$n->{Kids}} ) { + next if $in->{NodeType} ne $type; + + $outlist->{ $in->{astNodeName} } = $in; + } +} + +=head2 findOverride + + Parameters: root, node, name + + Looks for nodes of the same name as the parameter, in its parent + and the parent's ancestors. It returns a node if it finds one. + +=cut + +sub findOverride +{ + my ( $root, $node, $name ) = @_; + return undef if !exists $node->{InList}; + + foreach my $in ( @{$node->{InList}} ) { + my $n = $in->{Node}; + next unless defined $n && $n != $root && exists $n->{KidHash}; + + my $ref = $n->{KidHash}->{ $name }; + + return $n if defined $ref && $ref->{NodeType} eq "method"; + + if ( exists $n->{InList} ) { + $ref = findOverride( $root, $n, $name ); + return $ref if defined $ref; + } + } + + return undef; +} + +=head2 attachChild + + Parameters: parent, child + + Attaches child to the parent, setting Access, Kids + and KidHash of respective nodes. + +=cut + +sub attachChild +{ + my ( $parent, $child ) = @_; + confess "Attempt to attach ".$child->{astNodeName}." to an ". + "undefined parent\n" if !defined $parent; + + $child->AddProp( "Access", $parent->{KidAccess} ); + $child->AddProp( "Parent", $parent ); + + $parent->AddPropList( "Kids", $child ); + + if( !exists $parent->{KidHash} ) { + my $kh = Ast::New( "LookupTable" ); + $parent->AddProp( "KidHash", $kh ); + } + + $parent->{KidHash}->AddProp( $child->{astNodeName}, + $child ); +} + +=head2 makeClassList + + Parameters: node, outlist ref + + fills outlist with a sorted list of all direct, non-external + compound children of node. + +=cut + +sub makeClassList +{ + my ( $rootnode, $list ) = @_; + + @$list = (); + + Iter::LocalCompounds( $rootnode, + sub { + my $node = shift; + + my $her = join ( "::", heritage( $node ) ); + $node->AddProp( "FullName", $her ); + + if ( !exists $node->{DocNode}->{Internal} || + !$main::skipInternal ) { + push @$list, $node; + } + } ); + + @$list = sort { $a->{FullName} cmp $b->{FullName} } @$list; +} + +# +# Debugging utilities +# + +=head2 dumpAst + + Parameters: node, deep + Returns: none + + Does a recursive dump of the node and its children. + If deep is set, it is used as the recursion property, otherwise + "Kids" is used. + +=cut + +sub dumpAst +{ + my ( $node, $deep ) = @_; + + $deep = "Kids" if !defined $deep; + + print "\t" x $depth, $node->{astNodeName}, + " (", $node->{NodeType}, ")\n"; + + my $kid; + + foreach $kid ( $node->GetProps() ) { + print "\t" x $depth, " -\t", $kid, " -> ", $node->{$kid},"\n" + unless $kid =~ /^(astNodeName|NodeType|$deep)$/; + } + if ( exists $node->{InList} ) { + print "\t" x $depth, " -\tAncestors -> "; + foreach my $innode ( @{$node->{InList}} ) { + print $innode->{astNodeName} . ","; + } + print "\n"; + } + + print "\t" x $depth, " -\n" if (defined $node->{ $deep } && scalar(@{$node->{ $deep }}) != 0); + + $depth++; + foreach $kid ( @{$node->{ $deep }} ) { + dumpAst( $kid ); + } + + print "\t" x $depth, "Documentation nodes:\n" if defined + @{ $node->{Doc}->{ "Text" }}; + + foreach $kid ( @{ $node->{Doc}->{ "Text" }} ) { + dumpAst( $kid ); + } + + $depth--; +} + +=head2 testRef + + Parameters: rootnode + + Interactive testing of referencing system. Calling this + will use the readline library to allow interactive entering of + identifiers. If a matching node is found, its node name will be + printed. + +=cut + +sub testRef { + require Term::ReadLine; + + my $rootNode = $_[ 0 ]; + + my $term = new Term::ReadLine 'Testing findRef'; + + my $OUT = $term->OUT || *STDOUT{IO}; + my $prompt = "Identifier: "; + + while( defined ($_ = $term->readline($prompt)) ) { + + my $node = kdocAstUtil::findRef( $rootNode, $_ ); + + if( defined $node ) { + print $OUT "Reference: '", $node->{astNodeName}, + "', Type: '", $node->{NodeType},"'\n"; + } + else { + print $OUT "No reference found.\n"; + } + + $term->addhistory( $_ ) if /\S/; + } +} + +sub printDebugStats +{ + print "findRef: ", $refcalls, " calls, ", + $refiters, " iterations.\n"; +} + +sub External +{ + return defined $_[0]->{ExtSource}; +} + +sub Compound +{ + return defined $_[0]->{Compound}; +} + +sub localComp +{ + my ( $node ) = $_[0]; + return defined $node->{Compound} + && !defined $node->{ExtSource} + && $node->{NodeType} ne "Forward"; +} + +sub hasDoc +{ + return defined $_[0]->{DocNode}; +} + +### Warning: this returns the list of parents, e.g. the 3 words in KParts::ReadOnlyPart::SomeEnum +### It has nothing do to with inheritance. +sub heritage +{ + my $node = shift; + my @heritage; + + while( 1 ) { + push @heritage, $node->{astNodeName}; + + last unless defined $node->{Parent}; + $node = $node->{Parent}; + last unless defined $node->{Parent}; + } + + return reverse @heritage; +} + + +1; diff --git a/dcop/dcopidlng/kdocParseDoc.pm b/dcop/dcopidlng/kdocParseDoc.pm new file mode 100644 index 000000000..e5f19d50c --- /dev/null +++ b/dcop/dcopidlng/kdocParseDoc.pm @@ -0,0 +1,419 @@ +package kdocParseDoc; + +use Ast; +use strict; + +use vars qw/ $buffer $docNode %extraprops $currentProp $propType /; + +=head1 kdocParseDoc + + Routines for parsing of javadoc comments. + +=head2 newDocComment + + Parameters: begin (starting line of declaration) + + Reads a doc comment to the end and creates a new doc node. + + Read a line + check if it changes the current context + yes + flush old context + check if it is a non-text tag + (ie internal/deprecated etc) + yes + reset context to text + set associated property + no + set the new context + assign text to new buffer + no add to text buffer + continue + at end + flush anything pending. + +=cut + +sub newDocComment +{ + my( $text ) = @_; + return undef unless $text =~ m#/\*\*+#; + + setType( "DocText", 2 ); + $text =~ m#/\*#; # need to do the match again, otherwise /***/ doesn't parse + ### TODO update this method from kdoc + $buffer = $'; # everything after the first \* + $docNode = undef; + %extraprops = (); # used for textprops when flushing. + my $finished = 0; + my $inbounded = 0; + + if ( $buffer =~ m#\*/# ) { + $buffer = $`; + $finished = 1; + } + +PARSELOOP: + while ( defined $text && !$finished ) { + # read text and remove leading junk + $text = main::readSourceLine(); + next if !defined $text; + $text =~ s#^\s*\*(?!\/)##; + +# if ( $text =~ /^\s*<\/pre>/i ) { +# flushProp(); +# $inbounded = 0; +# } + if( $inbounded ) { + if ( $text =~ m#\*/# ) { + $finished = 1; + $text = $`; + } + $buffer .= $text; + next PARSELOOP; + } +# elsif ( $text =~ /^\s*
/i ) {
+#			textProp( "Pre" );
+#			$inbounded = 1;
+#		}
+		elsif ( $text =~ /^\s*$/ ) {
+			textProp( "ParaBreak", "\n" );
+		}
+		elsif ( $text =~ /^\s*\@internal\s*/ ) {
+			codeProp( "Internal", 1 );
+		}
+		elsif ( $text =~ /^\s*\@deprecated\s*/ ) {
+			codeProp( "Deprecated", 1 );
+		}
+		elsif ( $text =~ /^\s*\@reimplemented\s*/ ) {
+			codeProp( "Reimplemented", 1 );
+		}
+		elsif ( $text =~ /^\s*\@group\s*/ ) {
+			# logical group tag in which this node belongs
+			# multiples allowed
+
+			my $groups = $';
+			$groups =~ s/^\s*(.*?)\s*$/$1/;
+
+			if ( $groups ne "" ) {
+				foreach my $g ( split( /[^_\w]+/, $groups) ) {
+
+					codeProp( "InGroup", $g );
+				}
+			}
+		}
+		elsif ( $text =~ /^\s*\@defgroup\s+(\w+)\s*/ ) {
+			# parse group tag and description
+			my $grptag = $1;
+			my $grpdesc = $' eq "" ? $grptag : $';
+			
+			# create group node
+			my $grpnode = Ast::New( $grptag );
+			$grpnode->AddProp( "Desc", $grpdesc );
+			$grpnode->AddProp( "NodeType", "GroupDef" );
+
+			# attach
+			codeProp( "Groups", $grpnode );
+		}
+		elsif ( $text =~ /^\s*\@see\s*/ ) {
+			docListProp( "See" );
+		}
+		elsif( $text =~ /^\s*\@short\s*/ ) {
+			docProp( "ClassShort" );
+		}
+		elsif( $text =~ /^\s*\@author\s*/ ) {
+			docProp( "Author" );
+
+		}
+		elsif( $text =~ /^\s*\@version\s*/ ) {
+			docProp( "Version" );
+		}
+		elsif( $text =~ /^\s*\@id\s*/ ) {
+
+			docProp( "Id" );
+		}
+		elsif( $text =~ /^\s*\@since\s*/ ) {
+			docProp( "Since" );
+		}
+		elsif( $text =~ /^\s*\@returns?\s*/ ) {
+			docProp( "Returns" );
+		}
+		elsif( $text =~ /^\s*\@(?:throws|exception|raises)\s*/ ) {
+			docListProp( "Throws" );
+		}
+		elsif( $text =~ /^\s*\@image\s+([^\s]+)\s*/ ) {
+			textProp( "Image" );
+			$extraprops{ "Path" } = $1;
+		}
+		elsif( $text =~ /^\s*\@param\s+(\w+)\s*/ ) {
+			textProp( "Param" );
+			$extraprops{ "Name" } = $1;
+		}
+		elsif( $text =~ /^\s*\@sect\s+/ ) {
+
+			textProp( "DocSection" );
+		}
+		elsif( $text =~ /^\s*\@li\s+/ ) {
+
+			textProp( "ListItem" );
+		}
+		elsif ( $text =~ /^\s*\@libdoc\s+/ ) {
+			# Defines the text for the entire library
+			docProp( "LibDoc" );
+		}
+		else {
+			if ( $text =~ m#\*/# ) {
+				$finished = 1;
+				$text = $`;
+			}
+			$buffer .= $text;
+		}
+	}
+
+	flushProp();
+
+
+	return undef if !defined $docNode;
+
+# postprocess docnode
+
+	# add a . to the end of the short if required.
+	my $short = $docNode->{ClassShort};
+
+	if ( defined $short ) {
+		if ( !($short =~ /\.\s*$/) ) {
+			$docNode->{ClassShort} =~ s/\s*$/./;
+		}
+	}
+	else {
+		# use first line of normal text as short name.
+		if ( defined $docNode->{Text} ) {
+			my $node;
+			foreach $node ( @{$docNode->{Text}} ) {
+				next if $node->{NodeType} ne "DocText";
+				$short = $node->{astNodeName};
+				$short = $`."." if $short =~ /\./;
+				$docNode->{ClassShort} = $short;
+				goto shortdone;
+			}
+		}
+	}
+shortdone:
+
+# Join and break all word list props so that they are one string per list 
+# node, ie remove all commas and spaces.
+
+	recombineOnWords( $docNode, "See" );
+	recombineOnWords( $docNode, "Throws" );
+
+	return $docNode;
+}
+
+=head3 setType
+
+	Parameters: propname, proptype ( 0 = single, 1 = list, 2 = text )
+
+	Set the name and type of the pending property.
+
+=cut
+
+sub setType
+{
+	( $currentProp, $propType ) = @_;
+}
+
+=head3 flushProp
+
+	Flush any pending item and reset the buffer. type is set to DocText.
+
+=cut
+
+sub flushProp
+{
+	return if $buffer eq "";
+	initDocNode() unless defined $docNode;
+
+	if( $propType == 1 ) {
+		# list prop
+		$docNode->AddPropList( $currentProp, $buffer );
+	}
+	elsif ( $propType == 2 ) {
+		# text prop
+		my $textnode = Ast::New( $buffer );
+		$textnode->AddProp( 'NodeType', $currentProp );
+		$docNode->AddPropList( 'Text', $textnode );
+		
+		foreach my $prop ( keys %extraprops ) {
+			$textnode->AddProp( $prop, 
+				$extraprops{ $prop } );
+		}
+
+		%extraprops = ();
+	}
+	else {
+		# one-off prop
+		$docNode->AddProp( $currentProp, $buffer );
+	}
+
+	# reset buffer
+	$buffer = "";
+	setType( "DocText", 2 );
+}
+
+=head3 codeProp
+
+	Flush the last node, add a new property and reset type to DocText.
+
+=cut
+
+sub codeProp
+{
+	my( $prop, $val ) = @_;
+
+	flushProp();
+
+	initDocNode() unless defined $docNode;
+	$docNode->AddPropList( $prop, $val );
+	
+	setType( "DocText", 2 );
+
+}
+
+=head3 docListProp
+
+	The next item is a list property of docNode.
+
+=cut
+
+sub docListProp
+{
+	my( $prop ) = @_;
+
+	flushProp();
+
+	$buffer = $';
+	setType( $prop, 1 );
+}
+
+=head3 docProp
+
+	The next item is a simple property of docNode.
+
+=cut
+
+sub docProp
+{
+	my( $prop ) = @_;
+	
+	flushProp();
+
+	$buffer = $';
+	setType( $prop, 0 );
+}
+
+=head3 textProp
+
+	Parameters: prop, val
+
+	Set next item to be a 'Text' list node. if val is assigned, the
+	new node is assigned that text and flushed immediately. If this
+	is the case, the next item is given the 'DocText' text property.
+
+=cut
+
+sub textProp
+{
+	my( $prop, $val ) = @_;
+
+	flushProp();
+
+	if ( defined $val ) {
+		$buffer = $val;
+		setType( $prop, 2 );
+		flushProp();
+		$prop = "DocText";
+	}
+
+	setType( $prop, 2 );
+	$buffer = $';
+}
+
+
+=head3 initDocNode
+
+	Creates docNode if it is not defined.
+
+=cut
+
+sub initDocNode
+{
+	$docNode = Ast::New( "Doc" );
+	$docNode->AddProp( "NodeType", "DocNode" );
+}
+
+sub recombineOnWords
+{
+	my ( $docNode, $prop ) = @_;
+
+	if ( exists $docNode->{$prop} ) {
+		my @oldsee = @{$docNode->{$prop}};
+		@{$docNode->{$prop}} = split (/[\s,]+/, join( " ", @oldsee ));
+	}
+}
+
+###############
+
+=head2 attachDoc
+
+Connects a docnode to a code node, setting any other properties
+if required, such as groups, internal/deprecated flags etc.
+
+=cut
+
+sub attachDoc
+{
+	my ( $node, $doc, $rootnode ) = @_;
+
+	$node->AddProp( "DocNode", $doc );
+	$node->AddProp( "Internal", 1 ) if defined $doc->{Internal};
+	$node->AddProp( "Deprecated", 1 ) if defined $doc->{Deprecated};
+
+	# attach group definitions if they exist
+	if ( defined $doc->{Groups} ) {
+		my $groupdef = $rootnode->{Groups};
+		if( !defined $groupdef ) {
+			$groupdef = Ast::New( "Groups" );
+			$rootnode->AddProp( "Groups", $groupdef );
+		}
+
+		foreach my $grp ( @{$doc->{Groups}} ) {
+			if ( defined $groupdef->{ $grp->{astNodeName} } ) {
+				$groupdef->{ $grp->{ astNodeName}
+				}->AddProp( "Desc", $grp->{Desc} );
+			}
+			else {
+				$groupdef->AddProp( $grp->{astNodeName}, $grp );
+			}
+		}
+	}
+
+	# attach node to group index(es)
+	# create groups if not found, they may be parsed later.
+
+	if ( defined $doc->{InGroup} ) {
+		my $groupdef = $rootnode->{Groups};
+
+		foreach my $grp ( @{$doc->{InGroup}} ) {
+			if ( !exists $groupdef->{$grp} ) {
+				my $newgrp = Ast::New( $grp );
+				$newgrp->AddProp( "Desc", $grp );
+				$newgrp->AddProp( "NodeType", "GroupDef" );
+				$groupdef->AddProp( $grp, $newgrp );
+			}
+
+			$groupdef->{$grp}->AddPropList( "Kids", $node );
+		}
+	}
+}
+
+1;
diff --git a/dcop/dcopidlng/kdocUtil.pm b/dcop/dcopidlng/kdocUtil.pm
new file mode 100644
index 000000000..629147ac3
--- /dev/null
+++ b/dcop/dcopidlng/kdocUtil.pm
@@ -0,0 +1,189 @@
+
+package kdocUtil;
+
+use strict;
+
+
+=head1 kdocUtil
+
+	General utilities.
+
+=head2 countReg
+
+	Parameters: string, regexp
+
+	Returns the number of times of regexp occurs in string.
+
+=cut
+
+sub countReg
+{
+	my( $str, $regexp ) = @_;
+	my( $count ) = 0;
+
+	while( $str =~ /$regexp/s ) {
+		$count++;
+		
+		$str =~ s/$regexp//s;
+	}
+
+	return $count;
+}
+
+=head2 findCommonPrefix
+
+	Parameters: string, string
+
+	Returns the prefix common to both strings. An empty string
+	is returned if the strings have no common prefix.
+
+=cut
+
+sub findCommonPrefix
+{
+	my @s1 = split( "/", $_[0] );
+	my @s2 = split( "/", $_[1] );
+	my $accum = "";
+	my $len = ($#s2 > $#s1 ) ? $#s1 : $#s2;
+
+	for my $i ( 0..$len ) {
+#		print "Compare: $i '$s1[$i]', '$s2[$i]'\n";
+		last if $s1[ $i ] ne $s2[ $i ];
+		$accum .= $s1[ $i ]."/";
+	}
+
+	return $accum;
+}
+
+=head2 makeRelativePath
+
+	Parameters: localpath, destpath
+	
+	Returns a relative path to the destination from the local path,
+	after removal of any common prefix.
+
+=cut
+
+sub makeRelativePath
+{
+	my ( $from, $to ) = @_;
+
+	# remove prefix
+	$from .= '/' unless $from =~ m#/$#;
+	$to .= '/' unless $to =~ m#/$#;
+
+	my $pfx = findCommonPrefix( $from, $to );
+
+	if ( $pfx ne "" ) {
+		$from =~ s/^$pfx//g;
+		$to =~ s/^$pfx//g;
+	}
+#	print "Prefix is '$pfx'\n";
+	
+	$from =~ s#/+#/#g;
+	$to =~ s#/+#/#g;
+	$pfx = countReg( $from, '\/' );
+
+	my $rel = "../" x $pfx;
+	$rel .= $to;
+
+	return $rel;
+}
+
+sub hostName
+{
+	my $host = "";
+	my @hostenvs = qw( HOST HOSTNAME COMPUTERNAME );
+
+	# Host name
+	foreach my $evar ( @hostenvs ) {
+			next unless defined $ENV{ $evar };
+
+			$host = $ENV{ $evar };
+			last;
+	}
+
+	if( $host eq "" ) {
+			$host = `uname -n`;
+			chop $host;
+	}
+
+	return $host;
+}
+
+sub userName
+{
+	my $who = "";
+	my @userenvs = qw( USERNAME USER LOGNAME );
+
+	# User name
+	foreach my $evar ( @userenvs ) {
+			next unless defined $ENV{ $evar };
+
+			$who = $ENV{ $evar };
+			last;
+	}
+
+	if( $who eq "" ) {
+		if ( $who = `whoami` ) {
+				chop $who;
+		}
+		elsif ( $who - `who am i` ) {
+				$who = ( split (/ /, $who ) )[0];
+		}
+	}
+
+	return $who;
+}
+
+=head2 splitUnnested
+	Helper to split a list using a delimiter, but looking for
+	nesting with (), {}, [] and <>.
+        Example: splitting   int a, QPair d, e=","
+	on ',' will give 3 items in the list.
+
+	Parameter: delimiter, string
+	Returns: array, after splitting the string
+
+	Thanks to Ashley Winters
+=cut
+sub splitUnnested($$) {
+    my $delim = shift;
+    my $string = shift;
+    my(%open) = (
+        '[' => ']',
+        '(' => ')',
+        '<' => '>',
+        '{' => '}',
+    );
+    my(%close) = reverse %open;
+    my @ret;
+    my $depth = 0;
+    my $start = 0;
+    my $indoublequotes = 0;
+    while($string =~ /($delim|<<|>>|[][}{)(><\"])/g) {
+        my $c = $1;
+        if(!$depth and !$indoublequotes and $c eq $delim) {
+            my $len = pos($string) - $start - 1;
+            push @ret, substr($string, $start, $len);
+            $start = pos($string);
+        } elsif($open{$c}) {
+            $depth++;
+        } elsif($close{$c}) {
+            $depth--;
+        } elsif($c eq '"') {
+	    if ($indoublequotes) {
+		$indoublequotes = 0;
+	    } else {
+		$indoublequotes = 1;
+	    }
+	}
+    }
+
+    my $subs = substr($string, $start);
+    push @ret, $subs if ($subs);
+    return @ret;
+}
+
+1;
+
diff --git a/dcop/dcopidlng/run_test.sh b/dcop/dcopidlng/run_test.sh
new file mode 100755
index 000000000..bfa3aa8b3
--- /dev/null
+++ b/dcop/dcopidlng/run_test.sh
@@ -0,0 +1,14 @@
+#!/bin/sh
+
+# Regression testing: generate .kidl out of dcopidl_test.h and compare with expected baseline
+# Usage: $srcdir/run_test.sh $srcdir
+
+srcdir="$1"
+builddir=`pwd`
+# Make a symlink in dcopidlng's builddir, to have "./dcopidl_test.h" in the kidl
+test -f dcopidl_test.h || ln -s $srcdir/../dcopidl/dcopidl_test.h .
+# Note that dcopidlng might not be installed yet, so we can't use the dcopidlng script
+# (which looks into kde's datadir)
+dcopidlng="perl -I$srcdir $srcdir/kalyptus --allow_k_dcop_accessors -f dcopidl"
+$dcopidlng ./dcopidl_test.h > $builddir/dcopidl_new_output.kidl || exit 1
+diff -u $srcdir/../dcopidl/dcopidl_output.kidl $builddir/dcopidl_new_output.kidl
-- 
cgit v1.2.3