| Filename | /home/s1/perl5/perlbrew/perls/perl-5.22.1/lib/site_perl/5.22.1/x86_64-linux/File/Spec/Unix.pm |
| Statements | Executed 29 statements in 3.07ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 23µs | 26µs | File::Spec::Unix::BEGIN@3 |
| 1 | 1 | 1 | 13µs | 56µs | File::Spec::Unix::BEGIN@223 |
| 1 | 1 | 1 | 12µs | 75µs | File::Spec::Unix::BEGIN@130 |
| 1 | 1 | 1 | 9µs | 22µs | File::Spec::Unix::BEGIN@182 |
| 1 | 1 | 1 | 9µs | 35µs | File::Spec::Unix::BEGIN@4 |
| 1 | 1 | 1 | 9µs | 50µs | File::Spec::Unix::BEGIN@245 |
| 1 | 1 | 1 | 9µs | 48µs | File::Spec::Unix::BEGIN@139 |
| 1 | 1 | 1 | 8µs | 46µs | File::Spec::Unix::BEGIN@148 |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_cache_tmpdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_cached_tmpdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_collapse |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_cwd |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_pp_canonpath |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_pp_catdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_pp_catfile |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_same |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::_tmpdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::abs2rel |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::case_tolerant |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::catpath |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::curdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::devnull |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::file_name_is_absolute |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::join |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::no_upwards |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::path |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::rel2abs |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::rootdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::splitdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::splitpath |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::tmpdir |
| 0 | 0 | 0 | 0s | 0s | File::Spec::Unix::updir |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package File::Spec::Unix; | ||||
| 2 | |||||
| 3 | 2 | 35µs | 2 | 29µs | # spent 26µs (23+3) within File::Spec::Unix::BEGIN@3 which was called:
# once (23µs+3µs) by DateTime::TimeZone::Local::BEGIN@7 at line 3 # spent 26µs making 1 call to File::Spec::Unix::BEGIN@3
# spent 3µs making 1 call to strict::import |
| 4 | 2 | 534µs | 2 | 62µs | # spent 35µs (9+26) within File::Spec::Unix::BEGIN@4 which was called:
# once (9µs+26µs) by DateTime::TimeZone::Local::BEGIN@7 at line 4 # spent 35µs making 1 call to File::Spec::Unix::BEGIN@4
# spent 26µs making 1 call to vars::import |
| 5 | |||||
| 6 | 1 | 800ns | $VERSION = '3.62'; | ||
| 7 | 1 | 300ns | my $xs_version = $VERSION; | ||
| 8 | 1 | 1µs | $VERSION =~ tr/_//d; | ||
| 9 | |||||
| 10 | #dont try to load XSLoader and DynaLoader only to ultimately fail on miniperl | ||||
| 11 | 1 | 4µs | if(!defined &canonpath && defined &DynaLoader::boot_DynaLoader) { | ||
| 12 | 1 | 500ns | eval {#eval is questionable since we are handling potential errors like | ||
| 13 | #"Cwd object version 3.48 does not match bootstrap parameter 3.50 | ||||
| 14 | #at lib/DynaLoader.pm line 216." by having this eval | ||||
| 15 | 1 | 2µs | if ( $] >= 5.006 ) { | ||
| 16 | 1 | 900ns | require XSLoader; | ||
| 17 | 1 | 570µs | 1 | 561µs | XSLoader::load("Cwd", $xs_version); # spent 561µs making 1 call to XSLoader::load |
| 18 | } else { | ||||
| 19 | require Cwd; | ||||
| 20 | } | ||||
| 21 | }; | ||||
| 22 | } | ||||
| 23 | |||||
| 24 | =head1 NAME | ||||
| 25 | |||||
| 26 | File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules | ||||
| 27 | |||||
| 28 | =head1 SYNOPSIS | ||||
| 29 | |||||
| 30 | require File::Spec::Unix; # Done automatically by File::Spec | ||||
| 31 | |||||
| 32 | =head1 DESCRIPTION | ||||
| 33 | |||||
| 34 | Methods for manipulating file specifications. Other File::Spec | ||||
| 35 | modules, such as File::Spec::Mac, inherit from File::Spec::Unix and | ||||
| 36 | override specific methods. | ||||
| 37 | |||||
| 38 | =head1 METHODS | ||||
| 39 | |||||
| 40 | =over 2 | ||||
| 41 | |||||
| 42 | =item canonpath() | ||||
| 43 | |||||
| 44 | No physical check on the filesystem, but a logical cleanup of a | ||||
| 45 | path. On UNIX eliminates successive slashes and successive "/.". | ||||
| 46 | |||||
| 47 | $cpath = File::Spec->canonpath( $path ) ; | ||||
| 48 | |||||
| 49 | Note that this does *not* collapse F<x/../y> sections into F<y>. This | ||||
| 50 | is by design. If F</foo> on your system is a symlink to F</bar/baz>, | ||||
| 51 | then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive | ||||
| 52 | F<../>-removal would give you. If you want to do this kind of | ||||
| 53 | processing, you probably want C<Cwd>'s C<realpath()> function to | ||||
| 54 | actually traverse the filesystem cleaning up paths like this. | ||||
| 55 | |||||
| 56 | =cut | ||||
| 57 | |||||
| 58 | sub _pp_canonpath { | ||||
| 59 | my ($self,$path) = @_; | ||||
| 60 | return unless defined $path; | ||||
| 61 | |||||
| 62 | # Handle POSIX-style node names beginning with double slash (qnx, nto) | ||||
| 63 | # (POSIX says: "a pathname that begins with two successive slashes | ||||
| 64 | # may be interpreted in an implementation-defined manner, although | ||||
| 65 | # more than two leading slashes shall be treated as a single slash.") | ||||
| 66 | my $node = ''; | ||||
| 67 | my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; | ||||
| 68 | |||||
| 69 | |||||
| 70 | if ( $double_slashes_special | ||||
| 71 | && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { | ||||
| 72 | $node = $1; | ||||
| 73 | } | ||||
| 74 | # This used to be | ||||
| 75 | # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); | ||||
| 76 | # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail | ||||
| 77 | # (Mainly because trailing "" directories didn't get stripped). | ||||
| 78 | # Why would cygwin avoid collapsing multiple slashes into one? --jhi | ||||
| 79 | $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx | ||||
| 80 | $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx | ||||
| 81 | $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx | ||||
| 82 | $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx | ||||
| 83 | $path =~ s|^/\.\.$|/|; # /.. -> / | ||||
| 84 | $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx | ||||
| 85 | return "$node$path"; | ||||
| 86 | } | ||||
| 87 | 1 | 600ns | *canonpath = \&_pp_canonpath unless defined &canonpath; | ||
| 88 | |||||
| 89 | =item catdir() | ||||
| 90 | |||||
| 91 | Concatenate two or more directory names to form a complete path ending | ||||
| 92 | with a directory. But remove the trailing slash from the resulting | ||||
| 93 | string, because it doesn't look good, isn't necessary and confuses | ||||
| 94 | OS2. Of course, if this is the root directory, don't cut off the | ||||
| 95 | trailing slash :-) | ||||
| 96 | |||||
| 97 | =cut | ||||
| 98 | |||||
| 99 | sub _pp_catdir { | ||||
| 100 | my $self = shift; | ||||
| 101 | |||||
| 102 | $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' | ||||
| 103 | } | ||||
| 104 | 1 | 200ns | *catdir = \&_pp_catdir unless defined &catdir; | ||
| 105 | |||||
| 106 | =item catfile | ||||
| 107 | |||||
| 108 | Concatenate one or more directory names and a filename to form a | ||||
| 109 | complete path ending with a filename | ||||
| 110 | |||||
| 111 | =cut | ||||
| 112 | |||||
| 113 | sub _pp_catfile { | ||||
| 114 | my $self = shift; | ||||
| 115 | my $file = $self->canonpath(pop @_); | ||||
| 116 | return $file unless @_; | ||||
| 117 | my $dir = $self->catdir(@_); | ||||
| 118 | $dir .= "/" unless substr($dir,-1) eq "/"; | ||||
| 119 | return $dir.$file; | ||||
| 120 | } | ||||
| 121 | 1 | 100ns | *catfile = \&_pp_catfile unless defined &catfile; | ||
| 122 | |||||
| 123 | =item curdir | ||||
| 124 | |||||
| 125 | Returns a string representation of the current directory. "." on UNIX. | ||||
| 126 | |||||
| 127 | =cut | ||||
| 128 | |||||
| 129 | sub curdir { '.' } | ||||
| 130 | 2 | 56µs | 2 | 138µs | # spent 75µs (12+63) within File::Spec::Unix::BEGIN@130 which was called:
# once (12µs+63µs) by DateTime::TimeZone::Local::BEGIN@7 at line 130 # spent 75µs making 1 call to File::Spec::Unix::BEGIN@130
# spent 63µs making 1 call to constant::import |
| 131 | |||||
| 132 | =item devnull | ||||
| 133 | |||||
| 134 | Returns a string representation of the null device. "/dev/null" on UNIX. | ||||
| 135 | |||||
| 136 | =cut | ||||
| 137 | |||||
| 138 | sub devnull { '/dev/null' } | ||||
| 139 | 2 | 53µs | 2 | 88µs | # spent 48µs (9+40) within File::Spec::Unix::BEGIN@139 which was called:
# once (9µs+40µs) by DateTime::TimeZone::Local::BEGIN@7 at line 139 # spent 48µs making 1 call to File::Spec::Unix::BEGIN@139
# spent 40µs making 1 call to constant::import |
| 140 | |||||
| 141 | =item rootdir | ||||
| 142 | |||||
| 143 | Returns a string representation of the root directory. "/" on UNIX. | ||||
| 144 | |||||
| 145 | =cut | ||||
| 146 | |||||
| 147 | sub rootdir { '/' } | ||||
| 148 | 2 | 177µs | 2 | 84µs | # spent 46µs (8+38) within File::Spec::Unix::BEGIN@148 which was called:
# once (8µs+38µs) by DateTime::TimeZone::Local::BEGIN@7 at line 148 # spent 46µs making 1 call to File::Spec::Unix::BEGIN@148
# spent 38µs making 1 call to constant::import |
| 149 | |||||
| 150 | =item tmpdir | ||||
| 151 | |||||
| 152 | Returns a string representation of the first writable directory from | ||||
| 153 | the following list or the current directory if none from the list are | ||||
| 154 | writable: | ||||
| 155 | |||||
| 156 | $ENV{TMPDIR} | ||||
| 157 | /tmp | ||||
| 158 | |||||
| 159 | If running under taint mode, and if $ENV{TMPDIR} | ||||
| 160 | is tainted, it is not used. | ||||
| 161 | |||||
| 162 | =cut | ||||
| 163 | |||||
| 164 | 1 | 300ns | my ($tmpdir, %tmpenv); | ||
| 165 | # Cache and return the calculated tmpdir, recording which env vars | ||||
| 166 | # determined it. | ||||
| 167 | sub _cache_tmpdir { | ||||
| 168 | @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]}; | ||||
| 169 | return $tmpdir = $_[1]; | ||||
| 170 | } | ||||
| 171 | # Retrieve the cached tmpdir, checking first whether relevant env vars have | ||||
| 172 | # changed and invalidated the cache. | ||||
| 173 | sub _cached_tmpdir { | ||||
| 174 | shift; | ||||
| 175 | local $^W; | ||||
| 176 | return if grep $ENV{$_} ne $tmpenv{$_}, @_; | ||||
| 177 | return $tmpdir; | ||||
| 178 | } | ||||
| 179 | sub _tmpdir { | ||||
| 180 | my $self = shift; | ||||
| 181 | my @dirlist = @_; | ||||
| 182 | 2 | 328µs | 2 | 35µs | # spent 22µs (9+13) within File::Spec::Unix::BEGIN@182 which was called:
# once (9µs+13µs) by DateTime::TimeZone::Local::BEGIN@7 at line 182 # spent 22µs making 1 call to File::Spec::Unix::BEGIN@182
# spent 13µs making 1 call to strict::unimport |
| 183 | if ($taint) { # Check for taint mode on perl >= 5.8.0 | ||||
| 184 | require Scalar::Util; | ||||
| 185 | @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; | ||||
| 186 | } | ||||
| 187 | elsif ($] < 5.007) { # No ${^TAINT} before 5.8 | ||||
| 188 | @dirlist = grep { eval { eval('1'.substr $_,0,0) } } @dirlist; | ||||
| 189 | } | ||||
| 190 | |||||
| 191 | foreach (@dirlist) { | ||||
| 192 | next unless defined && -d && -w _; | ||||
| 193 | $tmpdir = $_; | ||||
| 194 | last; | ||||
| 195 | } | ||||
| 196 | $tmpdir = $self->curdir unless defined $tmpdir; | ||||
| 197 | $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); | ||||
| 198 | if ( !$self->file_name_is_absolute($tmpdir) ) { | ||||
| 199 | # See [perl #120593] for the full details | ||||
| 200 | # If possible, return a full path, rather than '.' or 'lib', but | ||||
| 201 | # jump through some hoops to avoid returning a tainted value. | ||||
| 202 | ($tmpdir) = grep { | ||||
| 203 | $taint ? ! Scalar::Util::tainted($_) : | ||||
| 204 | $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1 | ||||
| 205 | } $self->rel2abs($tmpdir), $tmpdir; | ||||
| 206 | } | ||||
| 207 | return $tmpdir; | ||||
| 208 | } | ||||
| 209 | |||||
| 210 | sub tmpdir { | ||||
| 211 | my $cached = $_[0]->_cached_tmpdir('TMPDIR'); | ||||
| 212 | return $cached if defined $cached; | ||||
| 213 | $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR'); | ||||
| 214 | } | ||||
| 215 | |||||
| 216 | =item updir | ||||
| 217 | |||||
| 218 | Returns a string representation of the parent directory. ".." on UNIX. | ||||
| 219 | |||||
| 220 | =cut | ||||
| 221 | |||||
| 222 | sub updir { '..' } | ||||
| 223 | 2 | 106µs | 2 | 100µs | # spent 56µs (13+44) within File::Spec::Unix::BEGIN@223 which was called:
# once (13µs+44µs) by DateTime::TimeZone::Local::BEGIN@7 at line 223 # spent 56µs making 1 call to File::Spec::Unix::BEGIN@223
# spent 44µs making 1 call to constant::import |
| 224 | |||||
| 225 | =item no_upwards | ||||
| 226 | |||||
| 227 | Given a list of file names, strip out those that refer to a parent | ||||
| 228 | directory. (Does not strip symlinks, only '.', '..', and equivalents.) | ||||
| 229 | |||||
| 230 | =cut | ||||
| 231 | |||||
| 232 | sub no_upwards { | ||||
| 233 | my $self = shift; | ||||
| 234 | return grep(!/^\.{1,2}\z/s, @_); | ||||
| 235 | } | ||||
| 236 | |||||
| 237 | =item case_tolerant | ||||
| 238 | |||||
| 239 | Returns a true or false value indicating, respectively, that alphabetic | ||||
| 240 | is not or is significant when comparing file specifications. | ||||
| 241 | |||||
| 242 | =cut | ||||
| 243 | |||||
| 244 | sub case_tolerant { 0 } | ||||
| 245 | 2 | 1.19ms | 2 | 90µs | # spent 50µs (9+40) within File::Spec::Unix::BEGIN@245 which was called:
# once (9µs+40µs) by DateTime::TimeZone::Local::BEGIN@7 at line 245 # spent 50µs making 1 call to File::Spec::Unix::BEGIN@245
# spent 40µs making 1 call to constant::import |
| 246 | |||||
| 247 | =item file_name_is_absolute | ||||
| 248 | |||||
| 249 | Takes as argument a path and returns true if it is an absolute path. | ||||
| 250 | |||||
| 251 | This does not consult the local filesystem on Unix, Win32, OS/2 or Mac | ||||
| 252 | OS (Classic). It does consult the working environment for VMS (see | ||||
| 253 | L<File::Spec::VMS/file_name_is_absolute>). | ||||
| 254 | |||||
| 255 | =cut | ||||
| 256 | |||||
| 257 | sub file_name_is_absolute { | ||||
| 258 | my ($self,$file) = @_; | ||||
| 259 | return scalar($file =~ m:^/:s); | ||||
| 260 | } | ||||
| 261 | |||||
| 262 | =item path | ||||
| 263 | |||||
| 264 | Takes no argument, returns the environment variable PATH as an array. | ||||
| 265 | |||||
| 266 | =cut | ||||
| 267 | |||||
| 268 | sub path { | ||||
| 269 | return () unless exists $ENV{PATH}; | ||||
| 270 | my @path = split(':', $ENV{PATH}); | ||||
| 271 | foreach (@path) { $_ = '.' if $_ eq '' } | ||||
| 272 | return @path; | ||||
| 273 | } | ||||
| 274 | |||||
| 275 | =item join | ||||
| 276 | |||||
| 277 | join is the same as catfile. | ||||
| 278 | |||||
| 279 | =cut | ||||
| 280 | |||||
| 281 | sub join { | ||||
| 282 | my $self = shift; | ||||
| 283 | return $self->catfile(@_); | ||||
| 284 | } | ||||
| 285 | |||||
| 286 | =item splitpath | ||||
| 287 | |||||
| 288 | ($volume,$directories,$file) = File::Spec->splitpath( $path ); | ||||
| 289 | ($volume,$directories,$file) = File::Spec->splitpath( $path, | ||||
| 290 | $no_file ); | ||||
| 291 | |||||
| 292 | Splits a path into volume, directory, and filename portions. On systems | ||||
| 293 | with no concept of volume, returns '' for volume. | ||||
| 294 | |||||
| 295 | For systems with no syntax differentiating filenames from directories, | ||||
| 296 | assumes that the last file is a path unless $no_file is true or a | ||||
| 297 | trailing separator or /. or /.. is present. On Unix this means that $no_file | ||||
| 298 | true makes this return ( '', $path, '' ). | ||||
| 299 | |||||
| 300 | The directory portion may or may not be returned with a trailing '/'. | ||||
| 301 | |||||
| 302 | The results can be passed to L</catpath()> to get back a path equivalent to | ||||
| 303 | (usually identical to) the original path. | ||||
| 304 | |||||
| 305 | =cut | ||||
| 306 | |||||
| 307 | sub splitpath { | ||||
| 308 | my ($self,$path, $nofile) = @_; | ||||
| 309 | |||||
| 310 | my ($volume,$directory,$file) = ('','',''); | ||||
| 311 | |||||
| 312 | if ( $nofile ) { | ||||
| 313 | $directory = $path; | ||||
| 314 | } | ||||
| 315 | else { | ||||
| 316 | $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; | ||||
| 317 | $directory = $1; | ||||
| 318 | $file = $2; | ||||
| 319 | } | ||||
| 320 | |||||
| 321 | return ($volume,$directory,$file); | ||||
| 322 | } | ||||
| 323 | |||||
| 324 | |||||
| 325 | =item splitdir | ||||
| 326 | |||||
| 327 | The opposite of L</catdir()>. | ||||
| 328 | |||||
| 329 | @dirs = File::Spec->splitdir( $directories ); | ||||
| 330 | |||||
| 331 | $directories must be only the directory portion of the path on systems | ||||
| 332 | that have the concept of a volume or that have path syntax that differentiates | ||||
| 333 | files from directories. | ||||
| 334 | |||||
| 335 | Unlike just splitting the directories on the separator, empty | ||||
| 336 | directory names (C<''>) can be returned, because these are significant | ||||
| 337 | on some OSs. | ||||
| 338 | |||||
| 339 | On Unix, | ||||
| 340 | |||||
| 341 | File::Spec->splitdir( "/a/b//c/" ); | ||||
| 342 | |||||
| 343 | Yields: | ||||
| 344 | |||||
| 345 | ( '', 'a', 'b', '', 'c', '' ) | ||||
| 346 | |||||
| 347 | =cut | ||||
| 348 | |||||
| 349 | sub splitdir { | ||||
| 350 | return split m|/|, $_[1], -1; # Preserve trailing fields | ||||
| 351 | } | ||||
| 352 | |||||
| 353 | |||||
| 354 | =item catpath() | ||||
| 355 | |||||
| 356 | Takes volume, directory and file portions and returns an entire path. Under | ||||
| 357 | Unix, $volume is ignored, and directory and file are concatenated. A '/' is | ||||
| 358 | inserted if needed (though if the directory portion doesn't start with | ||||
| 359 | '/' it is not added). On other OSs, $volume is significant. | ||||
| 360 | |||||
| 361 | =cut | ||||
| 362 | |||||
| 363 | sub catpath { | ||||
| 364 | my ($self,$volume,$directory,$file) = @_; | ||||
| 365 | |||||
| 366 | if ( $directory ne '' && | ||||
| 367 | $file ne '' && | ||||
| 368 | substr( $directory, -1 ) ne '/' && | ||||
| 369 | substr( $file, 0, 1 ) ne '/' | ||||
| 370 | ) { | ||||
| 371 | $directory .= "/$file" ; | ||||
| 372 | } | ||||
| 373 | else { | ||||
| 374 | $directory .= $file ; | ||||
| 375 | } | ||||
| 376 | |||||
| 377 | return $directory ; | ||||
| 378 | } | ||||
| 379 | |||||
| 380 | =item abs2rel | ||||
| 381 | |||||
| 382 | Takes a destination path and an optional base path returns a relative path | ||||
| 383 | from the base path to the destination path: | ||||
| 384 | |||||
| 385 | $rel_path = File::Spec->abs2rel( $path ) ; | ||||
| 386 | $rel_path = File::Spec->abs2rel( $path, $base ) ; | ||||
| 387 | |||||
| 388 | If $base is not present or '', then L<cwd()|Cwd> is used. If $base is | ||||
| 389 | relative, then it is converted to absolute form using | ||||
| 390 | L</rel2abs()>. This means that it is taken to be relative to | ||||
| 391 | L<cwd()|Cwd>. | ||||
| 392 | |||||
| 393 | On systems that have a grammar that indicates filenames, this ignores the | ||||
| 394 | $base filename. Otherwise all path components are assumed to be | ||||
| 395 | directories. | ||||
| 396 | |||||
| 397 | If $path is relative, it is converted to absolute form using L</rel2abs()>. | ||||
| 398 | This means that it is taken to be relative to L<cwd()|Cwd>. | ||||
| 399 | |||||
| 400 | No checks against the filesystem are made, so the result may not be correct if | ||||
| 401 | C<$base> contains symbolic links. (Apply | ||||
| 402 | L<Cwd::abs_path()|Cwd/abs_path> beforehand if that | ||||
| 403 | is a concern.) On VMS, there is interaction with the working environment, as | ||||
| 404 | logicals and macros are expanded. | ||||
| 405 | |||||
| 406 | Based on code written by Shigio Yamaguchi. | ||||
| 407 | |||||
| 408 | =cut | ||||
| 409 | |||||
| 410 | sub abs2rel { | ||||
| 411 | my($self,$path,$base) = @_; | ||||
| 412 | $base = $self->_cwd() unless defined $base and length $base; | ||||
| 413 | |||||
| 414 | ($path, $base) = map $self->canonpath($_), $path, $base; | ||||
| 415 | |||||
| 416 | my $path_directories; | ||||
| 417 | my $base_directories; | ||||
| 418 | |||||
| 419 | if (grep $self->file_name_is_absolute($_), $path, $base) { | ||||
| 420 | ($path, $base) = map $self->rel2abs($_), $path, $base; | ||||
| 421 | |||||
| 422 | my ($path_volume) = $self->splitpath($path, 1); | ||||
| 423 | my ($base_volume) = $self->splitpath($base, 1); | ||||
| 424 | |||||
| 425 | # Can't relativize across volumes | ||||
| 426 | return $path unless $path_volume eq $base_volume; | ||||
| 427 | |||||
| 428 | $path_directories = ($self->splitpath($path, 1))[1]; | ||||
| 429 | $base_directories = ($self->splitpath($base, 1))[1]; | ||||
| 430 | |||||
| 431 | # For UNC paths, the user might give a volume like //foo/bar that | ||||
| 432 | # strictly speaking has no directory portion. Treat it as if it | ||||
| 433 | # had the root directory for that volume. | ||||
| 434 | if (!length($base_directories) and $self->file_name_is_absolute($base)) { | ||||
| 435 | $base_directories = $self->rootdir; | ||||
| 436 | } | ||||
| 437 | } | ||||
| 438 | else { | ||||
| 439 | my $wd= ($self->splitpath($self->_cwd(), 1))[1]; | ||||
| 440 | $path_directories = $self->catdir($wd, $path); | ||||
| 441 | $base_directories = $self->catdir($wd, $base); | ||||
| 442 | } | ||||
| 443 | |||||
| 444 | # Now, remove all leading components that are the same | ||||
| 445 | my @pathchunks = $self->splitdir( $path_directories ); | ||||
| 446 | my @basechunks = $self->splitdir( $base_directories ); | ||||
| 447 | |||||
| 448 | if ($base_directories eq $self->rootdir) { | ||||
| 449 | return $self->curdir if $path_directories eq $self->rootdir; | ||||
| 450 | shift @pathchunks; | ||||
| 451 | return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); | ||||
| 452 | } | ||||
| 453 | |||||
| 454 | my @common; | ||||
| 455 | while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { | ||||
| 456 | push @common, shift @pathchunks ; | ||||
| 457 | shift @basechunks ; | ||||
| 458 | } | ||||
| 459 | return $self->curdir unless @pathchunks || @basechunks; | ||||
| 460 | |||||
| 461 | # @basechunks now contains the directories the resulting relative path | ||||
| 462 | # must ascend out of before it can descend to $path_directory. If there | ||||
| 463 | # are updir components, we must descend into the corresponding directories | ||||
| 464 | # (this only works if they are no symlinks). | ||||
| 465 | my @reverse_base; | ||||
| 466 | while( defined(my $dir= shift @basechunks) ) { | ||||
| 467 | if( $dir ne $self->updir ) { | ||||
| 468 | unshift @reverse_base, $self->updir; | ||||
| 469 | push @common, $dir; | ||||
| 470 | } | ||||
| 471 | elsif( @common ) { | ||||
| 472 | if( @reverse_base && $reverse_base[0] eq $self->updir ) { | ||||
| 473 | shift @reverse_base; | ||||
| 474 | pop @common; | ||||
| 475 | } | ||||
| 476 | else { | ||||
| 477 | unshift @reverse_base, pop @common; | ||||
| 478 | } | ||||
| 479 | } | ||||
| 480 | } | ||||
| 481 | my $result_dirs = $self->catdir( @reverse_base, @pathchunks ); | ||||
| 482 | return $self->canonpath( $self->catpath('', $result_dirs, '') ); | ||||
| 483 | } | ||||
| 484 | |||||
| 485 | sub _same { | ||||
| 486 | $_[1] eq $_[2]; | ||||
| 487 | } | ||||
| 488 | |||||
| 489 | =item rel2abs() | ||||
| 490 | |||||
| 491 | Converts a relative path to an absolute path. | ||||
| 492 | |||||
| 493 | $abs_path = File::Spec->rel2abs( $path ) ; | ||||
| 494 | $abs_path = File::Spec->rel2abs( $path, $base ) ; | ||||
| 495 | |||||
| 496 | If $base is not present or '', then L<cwd()|Cwd> is used. If $base is | ||||
| 497 | relative, then it is converted to absolute form using | ||||
| 498 | L</rel2abs()>. This means that it is taken to be relative to | ||||
| 499 | L<cwd()|Cwd>. | ||||
| 500 | |||||
| 501 | On systems that have a grammar that indicates filenames, this ignores | ||||
| 502 | the $base filename. Otherwise all path components are assumed to be | ||||
| 503 | directories. | ||||
| 504 | |||||
| 505 | If $path is absolute, it is cleaned up and returned using L</canonpath()>. | ||||
| 506 | |||||
| 507 | No checks against the filesystem are made. On VMS, there is | ||||
| 508 | interaction with the working environment, as logicals and | ||||
| 509 | macros are expanded. | ||||
| 510 | |||||
| 511 | Based on code written by Shigio Yamaguchi. | ||||
| 512 | |||||
| 513 | =cut | ||||
| 514 | |||||
| 515 | sub rel2abs { | ||||
| 516 | my ($self,$path,$base ) = @_; | ||||
| 517 | |||||
| 518 | # Clean up $path | ||||
| 519 | if ( ! $self->file_name_is_absolute( $path ) ) { | ||||
| 520 | # Figure out the effective $base and clean it up. | ||||
| 521 | if ( !defined( $base ) || $base eq '' ) { | ||||
| 522 | $base = $self->_cwd(); | ||||
| 523 | } | ||||
| 524 | elsif ( ! $self->file_name_is_absolute( $base ) ) { | ||||
| 525 | $base = $self->rel2abs( $base ) ; | ||||
| 526 | } | ||||
| 527 | else { | ||||
| 528 | $base = $self->canonpath( $base ) ; | ||||
| 529 | } | ||||
| 530 | |||||
| 531 | # Glom them together | ||||
| 532 | $path = $self->catdir( $base, $path ) ; | ||||
| 533 | } | ||||
| 534 | |||||
| 535 | return $self->canonpath( $path ) ; | ||||
| 536 | } | ||||
| 537 | |||||
| 538 | =back | ||||
| 539 | |||||
| 540 | =head1 COPYRIGHT | ||||
| 541 | |||||
| 542 | Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. | ||||
| 543 | |||||
| 544 | This program is free software; you can redistribute it and/or modify | ||||
| 545 | it under the same terms as Perl itself. | ||||
| 546 | |||||
| 547 | Please submit bug reports and patches to perlbug@perl.org. | ||||
| 548 | |||||
| 549 | =head1 SEE ALSO | ||||
| 550 | |||||
| 551 | L<File::Spec> | ||||
| 552 | |||||
| 553 | =cut | ||||
| 554 | |||||
| 555 | # Internal routine to File::Spec, no point in making this public since | ||||
| 556 | # it is the standard Cwd interface. Most of the platform-specific | ||||
| 557 | # File::Spec subclasses use this. | ||||
| 558 | sub _cwd { | ||||
| 559 | require Cwd; | ||||
| 560 | Cwd::getcwd(); | ||||
| 561 | } | ||||
| 562 | |||||
| 563 | |||||
| 564 | # Internal method to reduce xx\..\yy -> yy | ||||
| 565 | sub _collapse { | ||||
| 566 | my($fs, $path) = @_; | ||||
| 567 | |||||
| 568 | my $updir = $fs->updir; | ||||
| 569 | my $curdir = $fs->curdir; | ||||
| 570 | |||||
| 571 | my($vol, $dirs, $file) = $fs->splitpath($path); | ||||
| 572 | my @dirs = $fs->splitdir($dirs); | ||||
| 573 | pop @dirs if @dirs && $dirs[-1] eq ''; | ||||
| 574 | |||||
| 575 | my @collapsed; | ||||
| 576 | foreach my $dir (@dirs) { | ||||
| 577 | if( $dir eq $updir and # if we have an updir | ||||
| 578 | @collapsed and # and something to collapse | ||||
| 579 | length $collapsed[-1] and # and its not the rootdir | ||||
| 580 | $collapsed[-1] ne $updir and # nor another updir | ||||
| 581 | $collapsed[-1] ne $curdir # nor the curdir | ||||
| 582 | ) | ||||
| 583 | { # then | ||||
| 584 | pop @collapsed; # collapse | ||||
| 585 | } | ||||
| 586 | else { # else | ||||
| 587 | push @collapsed, $dir; # just hang onto it | ||||
| 588 | } | ||||
| 589 | } | ||||
| 590 | |||||
| 591 | return $fs->catpath($vol, | ||||
| 592 | $fs->catdir(@collapsed), | ||||
| 593 | $file | ||||
| 594 | ); | ||||
| 595 | } | ||||
| 596 | |||||
| 597 | |||||
| 598 | 1 | 12µs | 1; |