kalyptus/kdocUtil.pm

   1
   2 package kdocUtil;
   3
   4 use strict;
   5
   6
   7 =head1 kdocUtil
   8
   9         General utilities.
  10
  11 =head2 countReg
  12
  13         Parameters: string, regexp
  14
  15         Returns the number of times of regexp occurs in string.
  16
  17 =cut
  18
  19 sub countReg
  20 {
  21         my( $str, $regexp ) = @_;
  22         my( $count ) = 0;
  23
  24         while( $str =~ /$regexp/s ) {
  25                 $count++;
  26
  27                 $str =~ s/$regexp//s;
  28         }
  29
  30         return $count;
  31 }
  32
  33 =head2 findCommonPrefix
  34
  35         Parameters: string, string
  36
  37         Returns the prefix common to both strings. An empty string
  38         is returned if the strings have no common prefix.
  39
  40 =cut
  41
  42 sub findCommonPrefix
  43 {
  44         my @s1 = split( "/", $_[0] );
  45         my @s2 = split( "/", $_[1] );
  46         my $accum = "";
  47         my $len = ($#s2 > $#s1 ) ? $#s1 : $#s2;
  48
  49         for my $i ( 0..$len ) {
  50 #               print "Compare: $i '$s1[$i]', '$s2[$i]'\n";
  51                 last if $s1[ $i ] ne $s2[ $i ];
  52                 $accum .= $s1[ $i ]."/";
  53         }
  54
  55         return $accum;
  56 }
  57
  58 =head2 makeRelativePath
  59
  60         Parameters: localpath, destpath
  61
  62         Returns a relative path to the destination from the local path,
  63         after removal of any common prefix.
  64
  65 =cut
  66
  67 sub makeRelativePath
  68 {
  69         my ( $from, $to ) = @_;
  70
  71         # remove prefix
  72         $from .= '/' unless $from =~ m#/$#;
  73         $to .= '/' unless $to =~ m#/$#;
  74
  75         my $pfx = findCommonPrefix( $from, $to );
  76
  77         if ( $pfx ne "" ) {
  78                 $from =~ s/^$pfx//g;
  79                 $to =~ s/^$pfx//g;
  80         }
  81 #       print "Prefix is '$pfx'\n";
  82
  83         $from =~ s#/+#/#g;
  84         $to =~ s#/+#/#g;
  85         $pfx = countReg( $from, '\/' );
  86
  87         my $rel = "../" x $pfx;
  88         $rel .= $to;
  89
  90         return $rel;
  91 }
  92
  93 sub hostName
  94 {
  95         my $host = "";
  96         my @hostenvs = qw( HOST HOSTNAME COMPUTERNAME );
  97
  98         # Host name
  99         foreach my $evar ( @hostenvs ) {
 100                         next unless defined $ENV{ $evar };
 101
 102                         $host = $ENV{ $evar };
 103                         last;
 104         }
 105
 106         if( $host eq "" ) {
 107                         $host = `uname -n`;
 108                         chop $host;
 109         }
 110
 111         return $host;
 112 }
 113
 114 sub userName
 115 {
 116         my $who = "";
 117         my @userenvs = qw( USERNAME USER LOGNAME );
 118
 119         # User name
 120         foreach my $evar ( @userenvs ) {
 121                         next unless defined $ENV{ $evar };
 122
 123                         $who = $ENV{ $evar };
 124                         last;
 125         }
 126
 127         if( $who eq "" ) {
 128                 if ( $who = `whoami` ) {
 129                                 chop $who;
 130                 }
 131                 elsif ( $who - `who am i` ) {
 132                                 $who = ( split (/ /, $who ) )[0];
 133                 }
 134         }
 135
 136         return $who;
 137 }
 138
 139 =head2 splitUnnested
 140         Helper to split a list using a delimiter, but looking for
 141         nesting with (), {}, [] and <>.
 142         Example: splitting   int a, QPair<c,b> d, e=","
 143         on ',' will give 3 items in the list.
 144
 145         Parameter: delimiter, string
 146         Returns: array, after splitting the string
 147
 148         Thanks to Ashley Winters
 149 =cut
 150 sub splitUnnested($$) {
 151     my $delim = shift;
 152     my $string = shift;
 153     my(%open) = (
 154         '[' => ']',
 155         '(' => ')',
 156         '<' => '>',
 157         '{' => '}',
 158     );
 159     my(%close) = reverse %open;
 160     my @ret;
 161     my $depth = 0;
 162     my $start = 0;
 163     my $indoublequotes = 0;
 164     my $insinglequotes = 0;
 165     while($string =~ /($delim|<<|>>|[][}{)(><\"\'])/g) {
 166         my $c = $1;
 167         if(!$insinglequotes and !$indoublequotes) {
 168             if(!$depth and $c eq $delim) {
 169                 my $len = pos($string) - $start - 1;
 170                 push @ret, substr($string, $start, $len);
 171                 $start = pos($string);
 172             } elsif( $c eq "'") {
 173                 $insinglequotes = 1;
 174             } elsif( $c eq '"') {
 175                 $indoublequotes = 1;
 176             } elsif($open{$c}) {
 177                 $depth++;
 178             } elsif($close{$c}) {
 179                 $depth--;
 180             }
 181         } elsif($c eq '"' and $indoublequotes) {
 182                 $indoublequotes = 0;
 183         } elsif ($c eq "'" and $insinglequotes) {
 184                 $insinglequotes = 0;
 185         }
 186     }
 187
 188     my $subs = substr($string, $start);
 189     push @ret, $subs if ($subs);
 190     return @ret;
 191 }
 192
 193 1;
 194