perl/Git/SVN/Utils.pm

   1 package Git::SVN::Utils;
   2
   3 use strict;
   4 use warnings;
   5
   6 use SVN::Core;
   7
   8 use base qw(Exporter);
   9
  10 our @EXPORT_OK = qw(
  11         fatal
  12         can_compress
  13         canonicalize_path
  14         canonicalize_url
  15         join_paths
  16         add_path_to_url
  17 );
  18
  19
  20 =head1 NAME
  21
  22 Git::SVN::Utils - utility functions used across Git::SVN
  23
  24 =head1 SYNOPSIS
  25
  26     use Git::SVN::Utils qw(functions to import);
  27
  28 =head1 DESCRIPTION
  29
  30 This module contains functions which are useful across many different
  31 parts of Git::SVN.  Mostly it's a place to put utility functions
  32 rather than duplicate the code or have classes grabbing at other
  33 classes.
  34
  35 =head1 FUNCTIONS
  36
  37 All functions can be imported only on request.
  38
  39 =head3 fatal
  40
  41     fatal(@message);
  42
  43 Display a message and exit with a fatal error code.
  44
  45 =cut
  46
  47 # Note: not certain why this is in use instead of die.  Probably because
  48 # the exit code of die is 255?  Doesn't appear to be used consistently.
  49 sub fatal (@) { print STDERR "@_\n"; exit 1 }
  50
  51
  52 =head3 can_compress
  53
  54     my $can_compress = can_compress;
  55
  56 Returns true if Compress::Zlib is available, false otherwise.
  57
  58 =cut
  59
  60 my $can_compress;
  61 sub can_compress {
  62         return $can_compress if defined $can_compress;
  63
  64         return $can_compress = eval { require Compress::Zlib; };
  65 }
  66
  67
  68 =head3 canonicalize_path
  69
  70     my $canoncalized_path = canonicalize_path($path);
  71
  72 Converts $path into a canonical form which is safe to pass to the SVN
  73 API as a file path.
  74
  75 =cut
  76
  77 # Turn foo/../bar into bar
  78 sub _collapse_dotdot {
  79         my $path = shift;
  80
  81         1 while $path =~ s{/[^/]+/+\.\.}{};
  82         1 while $path =~ s{[^/]+/+\.\./}{};
  83         1 while $path =~ s{[^/]+/+\.\.}{};
  84
  85         return $path;
  86 }
  87
  88
  89 sub canonicalize_path {
  90         my $path = shift;
  91         my $rv;
  92
  93         # The 1.7 way to do it
  94         if ( defined &SVN::_Core::svn_dirent_canonicalize ) {
  95                 $path = _collapse_dotdot($path);
  96                 $rv = SVN::_Core::svn_dirent_canonicalize($path);
  97         }
  98         # The 1.6 way to do it
  99         # This can return undef on subversion-perl-1.4.2-2.el5 (CentOS 5.2)
 100         elsif ( defined &SVN::_Core::svn_path_canonicalize ) {
 101                 $path = _collapse_dotdot($path);
 102                 $rv = SVN::_Core::svn_path_canonicalize($path);
 103         }
 104
 105         return $rv if defined $rv;
 106
 107         # No SVN API canonicalization is available, or the SVN API
 108         # didn't return a successful result, do it ourselves
 109         return _canonicalize_path_ourselves($path);
 110 }
 111
 112
 113 sub _canonicalize_path_ourselves {
 114         my ($path) = @_;
 115         my $dot_slash_added = 0;
 116         if (substr($path, 0, 1) ne "/") {
 117                 $path = "./" . $path;
 118                 $dot_slash_added = 1;
 119         }
 120         $path =~ s#/+#/#g;
 121         $path =~ s#/\.(?:/|$)#/#g;
 122         $path = _collapse_dotdot($path);
 123         $path =~ s#/$##g;
 124         $path =~ s#^\./## if $dot_slash_added;
 125         $path =~ s#^/##;
 126         $path =~ s#^\.$##;
 127         return $path;
 128 }
 129
 130
 131 =head3 canonicalize_url
 132
 133     my $canonicalized_url = canonicalize_url($url);
 134
 135 Converts $url into a canonical form which is safe to pass to the SVN
 136 API as a URL.
 137
 138 =cut
 139
 140 sub canonicalize_url {
 141         my $url = shift;
 142
 143         # The 1.7 way to do it
 144         if ( defined &SVN::_Core::svn_uri_canonicalize ) {
 145                 return SVN::_Core::svn_uri_canonicalize($url);
 146         }
 147         # There wasn't a 1.6 way to do it, so we do it ourself.
 148         else {
 149                 return _canonicalize_url_ourselves($url);
 150         }
 151 }
 152
 153
 154 sub _canonicalize_url_path {
 155         my ($uri_path) = @_;
 156
 157         my @parts;
 158         foreach my $part (split m{/+}, $uri_path) {
 159                 $part =~ s/([^~\w.%+-]|%(?![a-fA-F0-9]{2}))/sprintf("%%%02X",ord($1))/eg;
 160                 push @parts, $part;
 161         }
 162
 163         return join('/', @parts);
 164 }
 165
 166 sub _canonicalize_url_ourselves {
 167         my ($url) = @_;
 168         if ($url =~ m#^([^:]+)://([^/]*)(.*)$#) {
 169                 my ($scheme, $domain, $uri) = ($1, $2, _canonicalize_url_path(canonicalize_path($3)));
 170                 $url = "$scheme://$domain$uri";
 171         }
 172         $url;
 173 }
 174
 175
 176 =head3 join_paths
 177
 178     my $new_path = join_paths(@paths);
 179
 180 Appends @paths together into a single path.  Any empty paths are ignored.
 181
 182 =cut
 183
 184 sub join_paths {
 185         my @paths = @_;
 186
 187         @paths = grep { defined $_ && length $_ } @paths;
 188
 189         return '' unless @paths;
 190         return $paths[0] if @paths == 1;
 191
 192         my $new_path = shift @paths;
 193         $new_path =~ s{/+$}{};
 194
 195         my $last_path = pop @paths;
 196         $last_path =~ s{^/+}{};
 197
 198         for my $path (@paths) {
 199                 $path =~ s{^/+}{};
 200                 $path =~ s{/+$}{};
 201                 $new_path .= "/$path";
 202         }
 203
 204         return $new_path .= "/$last_path";
 205 }
 206
 207
 208 =head3 add_path_to_url
 209
 210     my $new_url = add_path_to_url($url, $path);
 211
 212 Appends $path onto the $url.  If $path is empty, $url is returned unchanged.
 213
 214 =cut
 215
 216 sub add_path_to_url {
 217         my($url, $path) = @_;
 218
 219         return $url if !defined $path or !length $path;
 220
 221         # Strip trailing and leading slashes so we don't
 222         # wind up with http://x.com///path
 223         $url  =~ s{/+$}{};
 224         $path =~ s{^/+}{};
 225
 226         # If a path has a % in it, URI escape it so it's not
 227         # mistaken for a URI escape later.
 228         $path =~ s{%}{%25}g;
 229
 230         return join '/', $url, $path;
 231 }
 232
 233 1;