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 tqfindCommonPrefix
Parameters: string, string
Returns the prefix common to both strings. An empty string
is returned if the strings have no common prefix.
=cut
sub tqfindCommonPrefix
{
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 = tqfindCommonPrefix( $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;
|
