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