You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
libtqt-perl/kalyptus/kdocUtil.pm

195 lines
3.4 KiB

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;
my $insinglequotes = 0;
while($string =~ /($delim|<<|>>|[][}{)(><\"\'])/g) {
my $c = $1;
if(!$insinglequotes and !$indoublequotes) {
if(!$depth and $c eq $delim) {
my $len = pos($string) - $start - 1;
push @ret, substr($string, $start, $len);
$start = pos($string);
} elsif( $c eq "'") {
$insinglequotes = 1;
} elsif( $c eq '"') {
$indoublequotes = 1;
} elsif($open{$c}) {
$depth++;
} elsif($close{$c}) {
$depth--;
}
} elsif($c eq '"' and $indoublequotes) {
$indoublequotes = 0;
} elsif ($c eq "'" and $insinglequotes) {
$insinglequotes = 0;
}
}
my $subs = substr($string, $start);
push @ret, $subs if ($subs);
return @ret;
}
1;