git-svn-id: svn://anonsvn.kde.org/home/kde/branches/trinity/kdepim@1221130 283d02a7-25f6-0310-bc7c-ecb5cbfe19dav3.5.13-sru
tpearson
14 years ago
parent
f4fae92b67
commit
084c86a818
@ -1,91 +0,0 @@
|
||||
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};
|
||||
}
|
||||
|
||||
sub Visit {
|
||||
# Converts each of this AstNode's properties into global variables.
|
||||
# The global variables are introduced into package "main"
|
||||
# At the same time, a piece of code is formed to undo this work above -
|
||||
# $endCode essentially contains the values of these global variables
|
||||
# before they are mangled. endCode gets pushed into a stack (endCodes),
|
||||
# which is unwound by UnVisit().
|
||||
|
||||
local ($this, $pack) = @_;
|
||||
|
||||
|
||||
my $code = "";
|
||||
my $endCode = "";
|
||||
|
||||
|
||||
foreach my $k (keys %{$this}) {
|
||||
|
||||
my $glob = $pack."::".$k;
|
||||
|
||||
if ( defined $$glob ) {
|
||||
|
||||
if ( ${$glob} ne "" ) {
|
||||
$$glob =~ s/\'/\\\'/g;
|
||||
}
|
||||
|
||||
$endCode .= '$'.$pack.'::'.$k. " = '".$$glob."';";
|
||||
} else {
|
||||
$endCode .= '$'.$pack . "::". $k . ' = "";';
|
||||
}
|
||||
$code .= '$'.$pack . "::" . $k . "= \$this->{\"$k\"};";
|
||||
}
|
||||
push (@endCodes, $endCode);
|
||||
eval($code) if $code;
|
||||
}
|
||||
|
||||
sub UnVisit {
|
||||
my $code = pop(@endCodes);
|
||||
eval($code) if ($code);
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,532 +0,0 @@
|
||||
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;
|
||||
@ -1,5 +0,0 @@
|
||||
dnl we need to use our own copy, since kmailicalIface needs post 3.3 fixes in it
|
||||
dnl TODO: remove once we rely on kdelibs 3.4
|
||||
DCOPIDLNG='$(top_srcdir)/dcopidlng/dcopidlng'
|
||||
AC_SUBST(DCOPIDLNG)
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
#!/bin/sh
|
||||
trap "rm -f dcopidlng.stderr.$$" 0 1 2 15
|
||||
LIBDIR=`dirname $0`
|
||||
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
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,762 +0,0 @@
|
||||
=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 findNodes
|
||||
|
||||
Parameters: outlist ref, full list ref, key, value
|
||||
|
||||
Find all nodes in full list that have property "key=value".
|
||||
All resulting nodes are stored in outlist.
|
||||
|
||||
=cut
|
||||
|
||||
sub findNodes
|
||||
{
|
||||
my( $rOutList, $rInList, $key, $value ) = @_;
|
||||
|
||||
my $node;
|
||||
|
||||
foreach $node ( @{$rInList} ) {
|
||||
next if !exists $node->{ $key };
|
||||
if ( $node->{ $key } eq $value ) {
|
||||
push @$rOutList, $node;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
=head2 allTypes
|
||||
|
||||
Parameters: node list ref
|
||||
returns: list
|
||||
|
||||
Returns a sorted list of all distinct "NodeType"s in the nodes
|
||||
in the list.
|
||||
|
||||
=cut
|
||||
|
||||
sub allTypes
|
||||
{
|
||||
my ( $lref ) = @_;
|
||||
|
||||
my %types = ();
|
||||
foreach my $node ( @{$lref} ) {
|
||||
$types{ $node->{NodeType} } = 1;
|
||||
}
|
||||
|
||||
return sort keys %types;
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
=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;
|
||||
}
|
||||
|
||||
=head2 linkReferences
|
||||
|
||||
Parameters: root, node
|
||||
|
||||
Recursively links references in the documentation for each node
|
||||
to real nodes if they can be found. This should be called once
|
||||
the entire parse tree is filled.
|
||||
|
||||
=cut
|
||||
|
||||
sub linkReferences
|
||||
{
|
||||
my( $root, $node ) = @_;
|
||||
|
||||
if ( exists $node->{DocNode} ) {
|
||||
linkDocRefs( $root, $node, $node->{DocNode} );
|
||||
|
||||
if( exists $node->{Compound} ) {
|
||||
linkSee( $root, $node, $node->{DocNode} );
|
||||
}
|
||||
}
|
||||
|
||||
my $kids = $node->{Kids};
|
||||
return unless defined $kids;
|
||||
|
||||
foreach my $kid ( @$kids ) {
|
||||
# only continue in a leaf node if it has documentation.
|
||||
next if !exists $kid->{Kids} && !exists $kid->{DocNode};
|
||||
if( !exists $kid->{Compound} ) {
|
||||
linkSee( $root, $node, $kid->{DocNode} );
|
||||
}
|
||||
linkReferences( $root, $kid );
|
||||
}
|
||||
}
|
||||
|
||||
sub linkNamespaces
|
||||
{
|
||||
my ( $node ) = @_;
|
||||
|
||||
if ( defined $node->{ImpNames} ) {
|
||||
foreach my $space ( @{$node->{ImpNames}} ) {
|
||||
my $spnode = findRef( $node, $space );
|
||||
|
||||
if( defined $spnode ) {
|
||||
$node->AddPropList( "ExtNames", $spnode );
|
||||
}
|
||||
else {
|
||||
warn "namespace not found: $space\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return unless defined $node->{Compound} || !defined $node->{Kids};
|
||||
|
||||
|
||||
foreach my $kid ( @{$node->{Kids}} ) {
|
||||
next unless localComp( $kid );
|
||||
|
||||
linkNamespaces( $kid );
|
||||
}
|
||||
}
|
||||
|
||||
sub calcStats
|
||||
{
|
||||
my ( $stats, $root, $node ) = @_;
|
||||
# stats:
|
||||
# num types
|
||||
# num nested
|
||||
# num global funcs
|
||||
# num methods
|
||||
|
||||
|
||||
my $type = $node->{NodeType};
|
||||
|
||||
if ( $node eq $root ) {
|
||||
# global methods
|
||||
if ( defined $node->{Kids} ) {
|
||||
foreach my $kid ( @{$node->{Kids}} ) {
|
||||
$stats->{Global}++ if $kid->{NodeType} eq "method";
|
||||
}
|
||||
}
|
||||
|
||||
$node->AddProp( "Stats", $stats );
|
||||
}
|
||||
elsif ( kdocAstUtil::localComp( $node )
|
||||
|| $type eq "enum" || $type eq "typedef" ) {
|
||||
$stats->{Types}++;
|
||||
$stats->{Nested}++ if $node->{Parent} ne $root;
|
||||
}
|
||||
elsif( $type eq "method" ) {
|
||||
$stats->{Methods}++;
|
||||
}
|
||||
|
||||
return unless defined $node->{Compound} || !defined $node->{Kids};
|
||||
|
||||
foreach my $kid ( @{$node->{Kids}} ) {
|
||||
next if defined $kid->{ExtSource};
|
||||
calcStats( $stats, $root, $kid );
|
||||
}
|
||||
}
|
||||
|
||||
=head2 linkDocRefs
|
||||
|
||||
Parameters: root, node, docnode
|
||||
|
||||
Link references in the docs if they can be found. This should
|
||||
be called once the entire parse tree is filled.
|
||||
|
||||
=cut
|
||||
|
||||
sub linkDocRefs
|
||||
{
|
||||
my ( $root, $node, $docNode ) = @_;
|
||||
return unless exists $docNode->{Text};
|
||||
|
||||
my ($text, $ref, $item, $tosearch);
|
||||
|
||||
foreach $item ( @{$docNode->{Text}} ) {
|
||||
next if $item->{NodeType} ne 'Ref';
|
||||
|
||||
$text = $item->{astNodeName};
|
||||
|
||||
if ( $text =~ /^(?:#|::)/ ) {
|
||||
$text = $';
|
||||
$tosearch = $node;
|
||||
}
|
||||
else {
|
||||
$tosearch = $root;
|
||||
}
|
||||
|
||||
$ref = findRef( $tosearch, $text );
|
||||
$item->AddProp( 'Ref', $ref ) if defined $ref;
|
||||
|
||||
confess "Ref failed for ", $item->{astNodeName},
|
||||
"\n" unless defined $ref;
|
||||
}
|
||||
}
|
||||
|
||||
sub linkSee
|
||||
{
|
||||
my ( $root, $node, $docNode ) = @_;
|
||||
return unless exists $docNode->{See};
|
||||
|
||||
my ( $text, $tosearch, $ref );
|
||||
|
||||
foreach $text ( @{$docNode->{See}} ) {
|
||||
if ( $text =~ /^\s*(?:#|::)/ ) {
|
||||
$text = $';
|
||||
$tosearch = $node;
|
||||
}
|
||||
else {
|
||||
$tosearch = $root;
|
||||
}
|
||||
|
||||
$ref = findRef( $tosearch, $text );
|
||||
$docNode->AddPropList( 'SeeRef', $ref )
|
||||
if defined $ref;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
#
|
||||
# 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;
|
||||
}
|
||||
|
||||
sub refHeritage
|
||||
{
|
||||
my $node = shift;
|
||||
my @heritage;
|
||||
|
||||
while( 1 ) {
|
||||
push @heritage, $node;
|
||||
|
||||
last unless defined $node->{Parent};
|
||||
$node = $node->{Parent};
|
||||
last unless defined $node->{Parent};
|
||||
}
|
||||
|
||||
return reverse @heritage;
|
||||
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
@ -1,245 +0,0 @@
|
||||
|
||||
=head1 kdocLib
|
||||
|
||||
Writes out a library file.
|
||||
|
||||
NOTES ON THE NEW FORMAT
|
||||
|
||||
Stores: class name, members, hierarchy
|
||||
node types are not stored
|
||||
|
||||
|
||||
File Format Spec
|
||||
----------------
|
||||
|
||||
header
|
||||
zero or more members, each of
|
||||
method
|
||||
member
|
||||
class, each of
|
||||
inheritance
|
||||
zero or more members
|
||||
|
||||
|
||||
|
||||
Unrecognized lines ignored.
|
||||
|
||||
Sample
|
||||
------
|
||||
|
||||
<! KDOC Library HTML Reference File>
|
||||
<VERSION="2.0">
|
||||
<BASE URL="http://www.kde.org/API/kdecore/">
|
||||
|
||||
<C NAME="KApplication" REF="KApplication.html">
|
||||
<IN NAME="QObject">
|
||||
<ME NAME="getConfig" REF="KApplication.html#getConfig">
|
||||
<M NAME="" REF="">
|
||||
</C>
|
||||
|
||||
=cut
|
||||
|
||||
package kdocLib;
|
||||
use strict;
|
||||
|
||||
use Carp;
|
||||
use File::Path;
|
||||
use File::Basename;
|
||||
|
||||
use Ast;
|
||||
use kdocAstUtil;
|
||||
use kdocUtil;
|
||||
|
||||
|
||||
use vars qw/ $exe $lib $root $plang $outputdir $docpath $url $compress /;
|
||||
|
||||
BEGIN {
|
||||
$exe = basename $0;
|
||||
}
|
||||
|
||||
sub writeDoc
|
||||
{
|
||||
( $lib, $root, $plang, $outputdir, $docpath, $url,
|
||||
$compress ) = @_;
|
||||
my $outfile = "$outputdir/$lib.kalyptus";
|
||||
$url = $docpath unless defined $url;
|
||||
|
||||
mkpath( $outputdir ) unless -f $outputdir;
|
||||
|
||||
if( $compress ) {
|
||||
open( LIB, "| gzip -9 > \"$outfile.gz\"" )
|
||||
|| die "$exe: couldn't write to $outfile.gz\n";
|
||||
|
||||
}
|
||||
else {
|
||||
open( LIB, ">$outfile" )
|
||||
|| die "$exe: couldn't write to $outfile\n";
|
||||
}
|
||||
|
||||
my $libdesc = "";
|
||||
if ( defined $root->{LibDoc} ) {
|
||||
$libdesc="<LIBDESC>".$root->{LibDoc}->{astNodeName}."</LIBDESC>";
|
||||
}
|
||||
|
||||
print LIB<<LTEXT;
|
||||
<! KDOC Library HTML Reference File>
|
||||
<VERSION="$main::Version">
|
||||
<BASE URL="$url">
|
||||
<PLANG="$plang">
|
||||
<LIBNAME>$lib</LIBNAME>
|
||||
$libdesc
|
||||
|
||||
LTEXT
|
||||
|
||||
writeNode( $root, "" );
|
||||
close LIB;
|
||||
}
|
||||
|
||||
sub writeNode
|
||||
{
|
||||
my ( $n, $prefix ) = @_;
|
||||
return if !exists $n->{Compound};
|
||||
return if exists $n->{Forward} && !exists $n->{KidAccess};
|
||||
|
||||
if( $n != $root ) {
|
||||
$prefix .= $n->{astNodeName};
|
||||
print LIB "<C NAME=\"", $n->{astNodeName},
|
||||
"\" REF=\"$prefix.html\">\n";
|
||||
}
|
||||
else {
|
||||
print LIB "<STATS>\n";
|
||||
my $stats = $root->{Stats};
|
||||
foreach my $stat ( keys %$stats ) {
|
||||
print LIB "<STAT NAME=\"$stat\">",
|
||||
$stats->{$stat},"</STAT>\n";
|
||||
}
|
||||
print LIB "</STATS>\n";
|
||||
}
|
||||
|
||||
if( exists $n->{Ancestors} ) {
|
||||
my $in;
|
||||
foreach $in ( @{$n->{Ancestors}} ) {
|
||||
$in =~ s/\s+//g;
|
||||
print LIB "<IN NAME=\"",$in,"\">\n";
|
||||
}
|
||||
}
|
||||
|
||||
return if !exists $n->{Kids};
|
||||
my $kid;
|
||||
my $type;
|
||||
|
||||
foreach $kid ( @{$n->{Kids}} ) {
|
||||
next if exists $kid->{ExtSource}
|
||||
|| $kid->{Access} eq "private";
|
||||
|
||||
if ( exists $kid->{Compound} ) {
|
||||
if( $n != $root ) {
|
||||
writeNode( $kid, $prefix."::" );
|
||||
}
|
||||
else {
|
||||
writeNode( $kid, "" );
|
||||
}
|
||||
next;
|
||||
}
|
||||
|
||||
$type = $kid->{NodeType} eq "method" ?
|
||||
"ME" : "M";
|
||||
|
||||
print LIB "<$type NAME=\"", $kid->{astNodeName},
|
||||
"\" REF=\"$prefix.html#", $kid->{astNodeName}, "\">\n";
|
||||
}
|
||||
|
||||
if( $n != $root ) {
|
||||
print LIB "</C>\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub readLibrary
|
||||
{
|
||||
my( $rootsub, $name, $path, $relurl ) = @_;
|
||||
$path = "." unless defined $path;
|
||||
my $real = $path."/".$name.".kalyptus";
|
||||
my $url = ".";
|
||||
my @stack = ();
|
||||
my $version = "2.0";
|
||||
my $new;
|
||||
my $root = undef;
|
||||
my $n = undef;
|
||||
my $havecomp = -r "$real.gz";
|
||||
my $haveuncomp = -r "$real";
|
||||
|
||||
if ( $haveuncomp ) {
|
||||
open( LIB, "$real" ) || die "Can't read lib $real\n";
|
||||
}
|
||||
|
||||
if( $havecomp ) {
|
||||
if ( $haveuncomp ) {
|
||||
warn "$exe: two libs exist: $real and $real.gz. "
|
||||
."Using $real\n";
|
||||
}
|
||||
else {
|
||||
open( LIB, "gunzip < \"$real.gz\"|" )
|
||||
|| die "Can't read pipe gunzip < \"$real.gz\": $?\n";
|
||||
}
|
||||
}
|
||||
|
||||
while( <LIB> ) {
|
||||
next if /^\s*$/;
|
||||
if ( !/^\s*</ ) {
|
||||
close LIB;
|
||||
#readOldLibrary( $root, $name, $path );
|
||||
return;
|
||||
}
|
||||
|
||||
if( /<VER\w+\s+([\d\.]+)>/ ) {
|
||||
# TODO: what do we do with the version number?
|
||||
$version = $1;
|
||||
}
|
||||
elsif ( /<BASE\s*URL\s*=\s*"(.*?)"/ ) {
|
||||
$url = $1;
|
||||
$url .= "/" unless $url =~ m:/$:;
|
||||
|
||||
my $test = kdocUtil::makeRelativePath( $relurl, $url );
|
||||
$url = $test;
|
||||
}
|
||||
elsif( /<PLANG\s*=\s*"(.*?)">/ ) {
|
||||
$root = $rootsub->( $1 );
|
||||
$n = $root;
|
||||
}
|
||||
elsif ( /<C\s*NAME="(.*?)"\s*REF="(.*?)"\s*>/ ) {
|
||||
# class
|
||||
$new = Ast::New( $1 );
|
||||
$new->AddProp( "NodeType", "class" );
|
||||
$new->AddProp( "Compound", 1 );
|
||||
$new->AddProp( "ExtSource", $name );
|
||||
|
||||
# already escaped at this point!
|
||||
$new->AddProp( "Ref", $url.$2 );
|
||||
|
||||
$root = $n = $rootsub->( "CXX" ) unless defined $root;
|
||||
kdocAstUtil::attachChild( $n, $new );
|
||||
push @stack, $n;
|
||||
$n = $new;
|
||||
}
|
||||
elsif ( m#<IN\s*NAME\s*=\s*"(.*?)"\s*># ) {
|
||||
# ancestor
|
||||
kdocAstUtil::newInherit( $n, $1 );
|
||||
}
|
||||
elsif ( m#</C># ) {
|
||||
# end class
|
||||
$n = pop @stack;
|
||||
}
|
||||
elsif ( m#<(M\w*)\s+NAME="(.*?)"\s+REF="(.*?)"\s*># ) {
|
||||
# member
|
||||
$new = Ast::New( $2 );
|
||||
$new->AddProp( "NodeType", $1 eq "ME" ? "method" : "var" );
|
||||
$new->AddProp( "ExtSource", $name );
|
||||
$new->AddProp( "Flags", "" );
|
||||
$new->AddProp( "Ref", $url.$3 );
|
||||
|
||||
kdocAstUtil::attachChild( $n, $new );
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
@ -1,419 +0,0 @@
|
||||
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*<pre>/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;
|
||||
@ -1,189 +0,0 @@
|
||||
|
||||
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<c,b> 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;
|
||||
|
||||
Loading…
Reference in new issue