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 );
  17
  18
  19 =head1 NAME
  20
  21 Git::SVN::Utils - utility functions used across Git::SVN
  22
  23 =head1 SYNOPSIS
  24
  25     use Git::SVN::Utils qw(functions to import);
  26
  27 =head1 DESCRIPTION
  28
  29 This module contains functions which are useful across many different
  30 parts of Git::SVN.  Mostly it's a place to put utility functions
  31 rather than duplicate the code or have classes grabbing at other
  32 classes.
  33
  34 =head1 FUNCTIONS
  35
  36 All functions can be imported only on request.
  37
  38 =head3 fatal
  39
  40     fatal(@message);
  41
  42 Display a message and exit with a fatal error code.
  43
  44 =cut
  45
  46 # Note: not certain why this is in use instead of die.  Probably because
  47 # the exit code of die is 255?  Doesn't appear to be used consistently.
  48 sub fatal (@) { print STDERR "@_\n"; exit 1 }
  49
  50
  51 =head3 can_compress
  52
  53     my $can_compress = can_compress;
  54
  55 Returns true if Compress::Zlib is available, false otherwise.
  56
  57 =cut
  58
  59 my $can_compress;
  60 sub can_compress {
  61         return $can_compress if defined $can_compress;
  62
  63         return $can_compress = eval { require Compress::Zlib; };
  64 }
  65
  66
  67 =head3 canonicalize_path
  68
  69     my $canoncalized_path = canonicalize_path($path);
  70
  71 Converts $path into a canonical form which is safe to pass to the SVN
  72 API as a file path.
  73
  74 =cut
  75
  76 # Turn foo/../bar into bar
  77 sub _collapse_dotdot {
  78         my $path = shift;
  79
  80         1 while $path =~ s{/[^/]+/+\.\.}{};
  81         1 while $path =~ s{[^/]+/+\.\./}{};
  82         1 while $path =~ s{[^/]+/+\.\.}{};
  83
  84         return $path;
  85 }
  86
  87
  88 sub canonicalize_path {
  89         my $path = shift;
  90         my $rv;
  91
  92         # The 1.7 way to do it
  93         if ( defined &SVN::_Core::svn_dirent_canonicalize ) {
  94                 $path = _collapse_dotdot($path);
  95                 $rv = SVN::_Core::svn_dirent_canonicalize($path);
  96         }
  97         # The 1.6 way to do it
  98         # This can return undef on subversion-perl-1.4.2-2.el5 (CentOS 5.2)
  99         elsif ( defined &SVN::_Core::svn_path_canonicalize ) {
 100                 $path = _collapse_dotdot($path);
 101                 $rv = SVN::_Core::svn_path_canonicalize($path);
 102         }
 103
 104         return $rv if defined $rv;
 105
 106         # No SVN API canonicalization is available, or the SVN API
 107         # didn't return a successful result, do it ourselves
 108         return _canonicalize_path_ourselves($path);
 109 }
 110
 111
 112 sub _canonicalize_path_ourselves {
 113         my ($path) = @_;
 114         my $dot_slash_added = 0;
 115         if (substr($path, 0, 1) ne "/") {
 116                 $path = "./" . $path;
 117                 $dot_slash_added = 1;
 118         }
 119         $path =~ s#/+#/#g;
 120         $path =~ s#/\.(?:/|$)#/#g;
 121         $path = _collapse_dotdot($path);
 122         $path =~ s#/$##g;
 123         $path =~ s#^\./## if $dot_slash_added;
 124         $path =~ s#^/##;
 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 1;