TDE
/
tdepim
mirror of https://mirror.git.trinitydesktop.org/gitea/TDE/tdepim
0
0
Fork 0
Code Issues Releases Wiki Activity

Remove unused dcopidlng local copy

Browse Source 
git-svn-id: svn://anonsvn.kde.org/home/kde/branches/trinity/kdepim@1221130 283d02a7-25f6-0310-bc7c-ecb5cbfe19da
v3.5.13-sru
tpearson 14 years ago
parent f4fae92b67
commit 084c86a818
11 changed files with 0 additions and 7996 deletions
Show Stats Download Patch File Download Diff File

91
dcopidlng/Ast.pm
Unescape View File

@ -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;

532
dcopidlng/Iter.pm
Unescape View File

@ -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;

5
dcopidlng/configure.in.in
Unescape View File

@ -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)

10
dcopidlng/dcopidlng
Unescape View File

@ -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

1654
dcopidlng/kalyptus
View File

File diff suppressed because it is too large Load Diff

1047
dcopidlng/kalyptusCxxToDcopIDL.pm
View File

File diff suppressed because it is too large Load Diff

3042
dcopidlng/kalyptusDataDict.pm
View File

File diff suppressed because it is too large Load Diff

762
dcopidlng/kdocAstUtil.pm
Unescape View File

@ -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;

245
dcopidlng/kdocLib.pm
Unescape View File

@ -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;

419
dcopidlng/kdocParseDoc.pm
Unescape View File

@ -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;

189
dcopidlng/kdocUtil.pm
Unescape View File

@ -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;
Write Preview
Loading…
Cancel
Save