perl / Git / SVN / Utils.pmon commit Merge branch 'maint' (fc364c7)
   1package Git::SVN::Utils;
   2
   3use strict;
   4use warnings;
   5
   6use SVN::Core;
   7
   8use base qw(Exporter);
   9
  10our @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
  22Git::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
  30This module contains functions which are useful across many different
  31parts of Git::SVN.  Mostly it's a place to put utility functions
  32rather than duplicate the code or have classes grabbing at other
  33classes.
  34
  35=head1 FUNCTIONS
  36
  37All functions can be imported only on request.
  38
  39=head3 fatal
  40
  41    fatal(@message);
  42
  43Display 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.
  49sub fatal (@) { print STDERR "@_\n"; exit 1 }
  50
  51
  52=head3 can_compress
  53
  54    my $can_compress = can_compress;
  55
  56Returns true if Compress::Zlib is available, false otherwise.
  57
  58=cut
  59
  60my $can_compress;
  61sub 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
  72Converts $path into a canonical form which is safe to pass to the SVN
  73API as a file path.
  74
  75=cut
  76
  77# Turn foo/../bar into bar
  78sub _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
  89sub 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
 113sub _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
 134Converts $url into a canonical form which is safe to pass to the SVN
 135API as a URL.
 136
 137=cut
 138
 139sub 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
 153sub _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
 165sub _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
 179Appends @paths together into a single path.  Any empty paths are ignored.
 180
 181=cut
 182
 183sub 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
 211Appends $path onto the $url.  If $path is empty, $url is returned unchanged.
 212
 213=cut
 214
 215sub 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
 2321;