summaryrefslogtreecommitdiffstats
path: root/dcop/dcopidlng/kdocUtil.pm
blob: e045a679050d1b3a7efc3769136538aadc3b796c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
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, TQPair<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;