| 1 | package Git::SVN::Utils; |
| 2 | |
| 3 | use strict; |
| 4 | use warnings $ENV{GIT_PERL_FATAL_WARNINGS} ? qw(FATAL all) : (); |
| 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 | return $path; |
| 127 | } |
| 128 | |
| 129 | |
| 130 | =head3 canonicalize_url |
| 131 | |
| 132 | my $canonicalized_url = canonicalize_url($url); |
| 133 | |
| 134 | Converts $url into a canonical form which is safe to pass to the SVN |
| 135 | API as a URL. |
| 136 | |
| 137 | =cut |
| 138 | |
| 139 | sub canonicalize_url { |
| 140 | my $url = shift; |
| 141 | |
| 142 | # The 1.7 way to do it |
| 143 | if ( defined &SVN::_Core::svn_uri_canonicalize ) { |
| 144 | return SVN::_Core::svn_uri_canonicalize($url); |
| 145 | } |
| 146 | # There wasn't a 1.6 way to do it, so we do it ourself. |
| 147 | else { |
| 148 | return _canonicalize_url_ourselves($url); |
| 149 | } |
| 150 | } |
| 151 | |
| 152 | |
| 153 | sub _canonicalize_url_path { |
| 154 | my ($uri_path) = @_; |
| 155 | |
| 156 | my @parts; |
| 157 | foreach my $part (split m{/+}, $uri_path) { |
| 158 | $part =~ s/([^!\$%&'()*+,.\/\w:=\@_`~-]|%(?![a-fA-F0-9]{2}))/sprintf("%%%02X",ord($1))/eg; |
| 159 | push @parts, $part; |
| 160 | } |
| 161 | |
| 162 | return join('/', @parts); |
| 163 | } |
| 164 | |
| 165 | sub _canonicalize_url_ourselves { |
| 166 | my ($url) = @_; |
| 167 | if ($url =~ m#^([^:]+)://([^/]*)(.*)$#) { |
| 168 | my ($scheme, $domain, $uri) = ($1, $2, _canonicalize_url_path(canonicalize_path($3))); |
| 169 | $url = "$scheme://$domain$uri"; |
| 170 | } |
| 171 | $url; |
| 172 | } |
| 173 | |
| 174 | |
| 175 | =head3 join_paths |
| 176 | |
| 177 | my $new_path = join_paths(@paths); |
| 178 | |
| 179 | Appends @paths together into a single path. Any empty paths are ignored. |
| 180 | |
| 181 | =cut |
| 182 | |
| 183 | sub join_paths { |
| 184 | my @paths = @_; |
| 185 | |
| 186 | @paths = grep { defined $_ && length $_ } @paths; |
| 187 | |
| 188 | return '' unless @paths; |
| 189 | return $paths[0] if @paths == 1; |
| 190 | |
| 191 | my $new_path = shift @paths; |
| 192 | $new_path =~ s{/+$}{}; |
| 193 | |
| 194 | my $last_path = pop @paths; |
| 195 | $last_path =~ s{^/+}{}; |
| 196 | |
| 197 | for my $path (@paths) { |
| 198 | $path =~ s{^/+}{}; |
| 199 | $path =~ s{/+$}{}; |
| 200 | $new_path .= "/$path"; |
| 201 | } |
| 202 | |
| 203 | return $new_path .= "/$last_path"; |
| 204 | } |
| 205 | |
| 206 | |
| 207 | =head3 add_path_to_url |
| 208 | |
| 209 | my $new_url = add_path_to_url($url, $path); |
| 210 | |
| 211 | Appends $path onto the $url. If $path is empty, $url is returned unchanged. |
| 212 | |
| 213 | =cut |
| 214 | |
| 215 | sub add_path_to_url { |
| 216 | my($url, $path) = @_; |
| 217 | |
| 218 | return $url if !defined $path or !length $path; |
| 219 | |
| 220 | # Strip trailing and leading slashes so we don't |
| 221 | # wind up with http://x.com///path |
| 222 | $url =~ s{/+$}{}; |
| 223 | $path =~ s{^/+}{}; |
| 224 | |
| 225 | # If a path has a % in it, URI escape it so it's not |
| 226 | # mistaken for a URI escape later. |
| 227 | $path =~ s{%}{%25}g; |
| 228 | |
| 229 | return join '/', $url, $path; |
| 230 | } |
| 231 | |
| 232 | 1; |