From: Ilya Zakharevich Date: Fri, 21 Dec 2001 15:43:24 +0000 (-0500) Subject: OS/2 File::* modules X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f1e2092112ce19460895ba277191c080271a49b1;p=p5sagit%2Fp5-mst-13.2.git OS/2 File::* modules Message-ID: <20011221154324.A6524@math.ohio-state.edu> p4raw-id: //depot/perl@13838 --- diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm index 035c597..37faa6d 100644 --- a/lib/File/Basename.pm +++ b/lib/File/Basename.pm @@ -182,6 +182,11 @@ sub fileparse { ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; } + elsif ($fstype =~ /^os2/i) { + ($dirpath,$basename) = ($fullname =~ m#^((?:.*[:\\/])?)(.*)#s); + $dirpath = './' unless $dirpath; # Can't be 0 + $dirpath .= '/' unless $dirpath =~ m#[\\/]\z#; + } elsif ($fstype =~ /^MacOS/si) { ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); $dirpath = ':' unless $dirpath; @@ -251,14 +256,7 @@ sub dirname { } $dirname .= ":" unless $dirname =~ /:\z/; } - elsif ($fstype =~ /MSDOS/i) { - $dirname =~ s/([^:])[\\\/]*\z/$1/; - unless( length($basename) ) { - ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*\z/$1/; - } - } - elsif ($fstype =~ /MSWin32/i) { + elsif ($fstype =~ /MS(DOS|Win32)|os2/i) { $dirname =~ s/([^:])[\\\/]*\z/$1/; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; diff --git a/lib/File/Spec/OS2.pm b/lib/File/Spec/OS2.pm index 6392ba4..b494e2c 100644 --- a/lib/File/Spec/OS2.pm +++ b/lib/File/Spec/OS2.pm @@ -52,6 +52,233 @@ sub tmpdir { return $tmpdir; } +=item canonpath + +No physical check on the filesystem, but a logical cleanup of a +path. On UNIX eliminated successive slashes and successive "/.". + +=cut + +sub canonpath { + my ($self,$path) = @_; + $path =~ s/^([a-z]:)/\l$1/s; + $path =~ s|\\|/|g; + $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx + $path =~ s|/\Z(?!\n)|| + unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx + return $path; +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '/', '/.', '/..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, undef ). + +Separators accepted are \ and /. + +Volumes can be drive letters or UNC sharenames (\\server\share). + +The results can be passed to L to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b//c/" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + split m|[\\/]|, $directories, -1; +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s && + $volume =~ m@[^\\/]\Z(?!\n)@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '/' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } else { + $path = $self->canonpath( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = Cwd::sys_cwd() ; + } elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my $base_directories = ($self->splitpath( $base, 1 ))[1] ; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '/', @pathchunks ); + $base_directories = CORE::join( '/', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories/$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + return $self->canonpath( + $self->catpath( "", $path_directories, $path_file ) + ) ; +} + + +sub rel2abs { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = Cwd::sys_cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( $path_directories, $path_file ) = + ($self->splitpath( $path, 1 ))[1,2] ; + + my ( $base_volume, $base_directories ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} + 1; __END__