From 460c52653ab0dcca6f19a4f492ed2c5e4e963ab0 Mon Sep 17 00:00:00 2001
From: toma <toma@283d02a7-25f6-0310-bc7c-ecb5cbfe19da>
Date: Wed, 25 Nov 2009 17:56:58 +0000
Subject: Copy the KDE 3.5 branch to branches/trinity for new KDE 3.5 features.
 BUG:215923

git-svn-id: svn://anonsvn.kde.org/home/kde/branches/trinity/kdepim@1054174 283d02a7-25f6-0310-bc7c-ecb5cbfe19da
---
 dcopidlng/kdocUtil.pm | 189 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 189 insertions(+)
 create mode 100644 dcopidlng/kdocUtil.pm

(limited to 'dcopidlng/kdocUtil.pm')

diff --git a/dcopidlng/kdocUtil.pm b/dcopidlng/kdocUtil.pm
new file mode 100644
index 000000000..629147ac3
--- /dev/null
+++ b/dcopidlng/kdocUtil.pm
@@ -0,0 +1,189 @@
+
+package kdocUtil;
+
+use strict;
+
+
+=head1 kdocUtil
+
+	General utilities.
+
+=head2 countReg
+
+	Parameters: string, regexp
+
+	Returns the number of times of regexp occurs in string.
+
+=cut
+
+sub countReg
+{
+	my( $str, $regexp ) = @_;
+	my( $count ) = 0;
+
+	while( $str =~ /$regexp/s ) {
+		$count++;
+		
+		$str =~ s/$regexp//s;
+	}
+
+	return $count;
+}
+
+=head2 findCommonPrefix
+
+	Parameters: string, string
+
+	Returns the prefix common to both strings. An empty string
+	is returned if the strings have no common prefix.
+
+=cut
+
+sub findCommonPrefix
+{
+	my @s1 = split( "/", $_[0] );
+	my @s2 = split( "/", $_[1] );
+	my $accum = "";
+	my $len = ($#s2 > $#s1 ) ? $#s1 : $#s2;
+
+	for my $i ( 0..$len ) {
+#		print "Compare: $i '$s1[$i]', '$s2[$i]'\n";
+		last if $s1[ $i ] ne $s2[ $i ];
+		$accum .= $s1[ $i ]."/";
+	}
+
+	return $accum;
+}
+
+=head2 makeRelativePath
+
+	Parameters: localpath, destpath
+	
+	Returns a relative path to the destination from the local path,
+	after removal of any common prefix.
+
+=cut
+
+sub makeRelativePath
+{
+	my ( $from, $to ) = @_;
+
+	# remove prefix
+	$from .= '/' unless $from =~ m#/$#;
+	$to .= '/' unless $to =~ m#/$#;
+
+	my $pfx = findCommonPrefix( $from, $to );
+
+	if ( $pfx ne "" ) {
+		$from =~ s/^$pfx//g;
+		$to =~ s/^$pfx//g;
+	}
+#	print "Prefix is '$pfx'\n";
+	
+	$from =~ s#/+#/#g;
+	$to =~ s#/+#/#g;
+	$pfx = countReg( $from, '\/' );
+
+	my $rel = "../" x $pfx;
+	$rel .= $to;
+
+	return $rel;
+}
+
+sub hostName
+{
+	my $host = "";
+	my @hostenvs = qw( HOST HOSTNAME COMPUTERNAME );
+
+	# Host name
+	foreach my $evar ( @hostenvs ) {
+			next unless defined $ENV{ $evar };
+
+			$host = $ENV{ $evar };
+			last;
+	}
+
+	if( $host eq "" ) {
+			$host = `uname -n`;
+			chop $host;
+	}
+
+	return $host;
+}
+
+sub userName
+{
+	my $who = "";
+	my @userenvs = qw( USERNAME USER LOGNAME );
+
+	# User name
+	foreach my $evar ( @userenvs ) {
+			next unless defined $ENV{ $evar };
+
+			$who = $ENV{ $evar };
+			last;
+	}
+
+	if( $who eq "" ) {
+		if ( $who = `whoami` ) {
+				chop $who;
+		}
+		elsif ( $who - `who am i` ) {
+				$who = ( split (/ /, $who ) )[0];
+		}
+	}
+
+	return $who;
+}
+
+=head2 splitUnnested
+	Helper to split a list using a delimiter, but looking for
+	nesting with (), {}, [] and <>.
+        Example: splitting   int a, QPair<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;
+
-- 
cgit v1.2.1