1N/Apackage File::Spec::Win32;
1N/A
1N/Ause strict;
1N/A
1N/Ause vars qw(@ISA $VERSION);
1N/Arequire File::Spec::Unix;
1N/A
1N/A$VERSION = '1.4';
1N/A
1N/A@ISA = qw(File::Spec::Unix);
1N/A
1N/A=head1 NAME
1N/A
1N/AFile::Spec::Win32 - methods for Win32 file specs
1N/A
1N/A=head1 SYNOPSIS
1N/A
1N/A require File::Spec::Win32; # Done internally by File::Spec if needed
1N/A
1N/A=head1 DESCRIPTION
1N/A
1N/ASee File::Spec::Unix for a documentation of the methods provided
1N/Athere. This package overrides the implementation of these methods, not
1N/Athe semantics.
1N/A
1N/A=over 4
1N/A
1N/A=item devnull
1N/A
1N/AReturns a string representation of the null device.
1N/A
1N/A=cut
1N/A
1N/Asub devnull {
1N/A return "nul";
1N/A}
1N/A
1N/A=item tmpdir
1N/A
1N/AReturns a string representation of the first existing directory
1N/Afrom the following list:
1N/A
1N/A $ENV{TMPDIR}
1N/A $ENV{TEMP}
1N/A $ENV{TMP}
1N/A SYS:/temp
1N/A C:/temp
1N/A /tmp
1N/A /
1N/A
1N/AThe SYS:/temp is preferred in Novell NetWare (the File::Spec::Win32
1N/Ais used also for NetWare).
1N/A
1N/ASince Perl 5.8.0, if running under taint mode, and if the environment
1N/Avariables are tainted, they are not used.
1N/A
1N/A=cut
1N/A
1N/Amy $tmpdir;
1N/Asub tmpdir {
1N/A return $tmpdir if defined $tmpdir;
1N/A my $self = shift;
1N/A $tmpdir = $self->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
1N/A 'SYS:/temp',
1N/A 'C:/temp',
1N/A '/tmp',
1N/A '/' );
1N/A}
1N/A
1N/Asub case_tolerant {
1N/A return 1;
1N/A}
1N/A
1N/Asub file_name_is_absolute {
1N/A my ($self,$file) = @_;
1N/A return scalar($file =~ m{^([a-z]:)?[\\/]}is);
1N/A}
1N/A
1N/A=item catfile
1N/A
1N/AConcatenate one or more directory names and a filename to form a
1N/Acomplete path ending with a filename
1N/A
1N/A=cut
1N/A
1N/Asub catfile {
1N/A my $self = shift;
1N/A my $file = $self->canonpath(pop @_);
1N/A return $file unless @_;
1N/A my $dir = $self->catdir(@_);
1N/A $dir .= "\\" unless substr($dir,-1) eq "\\";
1N/A return $dir.$file;
1N/A}
1N/A
1N/Asub catdir {
1N/A my $self = shift;
1N/A my @args = @_;
1N/A foreach (@args) {
1N/A tr[/][\\];
1N/A # append a backslash to each argument unless it has one there
1N/A $_ .= "\\" unless m{\\$};
1N/A }
1N/A return $self->canonpath(join('', @args));
1N/A}
1N/A
1N/Asub path {
1N/A my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
1N/A my @path = split(';',$path);
1N/A foreach (@path) { $_ = '.' if $_ eq '' }
1N/A return @path;
1N/A}
1N/A
1N/A=item canonpath
1N/A
1N/ANo physical check on the filesystem, but a logical cleanup of a
1N/Apath. On UNIX eliminated successive slashes and successive "/.".
1N/AOn Win32 makes
1N/A
1N/A dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
1N/A dir1\dir2\dir3\...\dir4 -> \dir\dir4
1N/A
1N/A=cut
1N/A
1N/Asub canonpath {
1N/A my ($self,$path) = @_;
1N/A my $orig_path = $path;
1N/A $path =~ s/^([a-z]:)/\u$1/s;
1N/A $path =~ s|/|\\|g;
1N/A $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx
1N/A $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx
1N/A $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx
1N/A $path =~ s|\\\Z(?!\n)||
1N/A unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx
1N/A # xx1/xx2/xx3/../../xx -> xx1/xx
1N/A $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
1N/A $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up
1N/A return $path if $path =~ m|^\.\.|; # skip relative paths
1N/A return $path unless $path =~ /\.\./; # too few .'s to cleanup
1N/A return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup
1N/A $path =~ s{^\\\.\.$}{\\}; # \.. -> \
1N/A 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
1N/A
1N/A my ($vol,$dirs,$file) = $self->splitpath($path);
1N/A my @dirs = $self->splitdir($dirs);
1N/A my (@base_dirs, @path_dirs);
1N/A my $dest = \@base_dirs;
1N/A for my $dir (@dirs){
1N/A $dest = \@path_dirs if $dir eq $self->updir;
1N/A push @$dest, $dir;
1N/A }
1N/A # for each .. in @path_dirs pop one item from
1N/A # @base_dirs
1N/A while (my $dir = shift @path_dirs){
1N/A unless ($dir eq $self->updir){
1N/A unshift @path_dirs, $dir;
1N/A last;
1N/A }
1N/A pop @base_dirs;
1N/A }
1N/A $path = $self->catpath(
1N/A $vol,
1N/A $self->catdir(@base_dirs, @path_dirs),
1N/A $file
1N/A );
1N/A return $path;
1N/A}
1N/A
1N/A=item splitpath
1N/A
1N/A ($volume,$directories,$file) = File::Spec->splitpath( $path );
1N/A ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
1N/A
1N/ASplits a path into volume, directory, and filename portions. Assumes that
1N/Athe last file is a path unless the path ends in '\\', '\\.', '\\..'
1N/Aor $no_file is true. On Win32 this means that $no_file true makes this return
1N/A( $volume, $path, '' ).
1N/A
1N/ASeparators accepted are \ and /.
1N/A
1N/AVolumes can be drive letters or UNC sharenames (\\server\share).
1N/A
1N/AThe results can be passed to L</catpath> to get back a path equivalent to
1N/A(usually identical to) the original path.
1N/A
1N/A=cut
1N/A
1N/Asub splitpath {
1N/A my ($self,$path, $nofile) = @_;
1N/A my ($volume,$directory,$file) = ('','','');
1N/A if ( $nofile ) {
1N/A $path =~
1N/A m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
1N/A (.*)
1N/A }xs;
1N/A $volume = $1;
1N/A $directory = $2;
1N/A }
1N/A else {
1N/A $path =~
1N/A m{^ ( (?: [a-zA-Z]: |
1N/A (?:\\\\|//)[^\\/]+[\\/][^\\/]+
1N/A )?
1N/A )
1N/A ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
1N/A (.*)
1N/A }xs;
1N/A $volume = $1;
1N/A $directory = $2;
1N/A $file = $3;
1N/A }
1N/A
1N/A return ($volume,$directory,$file);
1N/A}
1N/A
1N/A
1N/A=item splitdir
1N/A
1N/AThe opposite of L<catdir()|File::Spec/catdir()>.
1N/A
1N/A @dirs = File::Spec->splitdir( $directories );
1N/A
1N/A$directories must be only the directory portion of the path on systems
1N/Athat have the concept of a volume or that have path syntax that differentiates
1N/Afiles from directories.
1N/A
1N/AUnlike just splitting the directories on the separator, leading empty and
1N/Atrailing directory entries can be returned, because these are significant
1N/Aon some OSs. So,
1N/A
1N/A File::Spec->splitdir( "/a/b/c" );
1N/A
1N/AYields:
1N/A
1N/A ( '', 'a', 'b', '', 'c', '' )
1N/A
1N/A=cut
1N/A
1N/Asub splitdir {
1N/A my ($self,$directories) = @_ ;
1N/A #
1N/A # split() likes to forget about trailing null fields, so here we
1N/A # check to be sure that there will not be any before handling the
1N/A # simple case.
1N/A #
1N/A if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
1N/A return split( m|[\\/]|, $directories );
1N/A }
1N/A else {
1N/A #
1N/A # since there was a trailing separator, add a file name to the end,
1N/A # then do the split, then replace it with ''.
1N/A #
1N/A my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
1N/A $directories[ $#directories ]= '' ;
1N/A return @directories ;
1N/A }
1N/A}
1N/A
1N/A
1N/A=item catpath
1N/A
1N/ATakes volume, directory and file portions and returns an entire path. Under
1N/AUnix, $volume is ignored, and this is just like catfile(). On other OSs,
1N/Athe $volume become significant.
1N/A
1N/A=cut
1N/A
1N/Asub catpath {
1N/A my ($self,$volume,$directory,$file) = @_;
1N/A
1N/A # If it's UNC, make sure the glue separator is there, reusing
1N/A # whatever separator is first in the $volume
1N/A $volume .= $1
1N/A if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
1N/A $directory =~ m@^[^\\/]@s
1N/A ) ;
1N/A
1N/A $volume .= $directory ;
1N/A
1N/A # If the volume is not just A:, make sure the glue separator is
1N/A # there, reusing whatever separator is first in the $volume if possible.
1N/A if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
1N/A $volume =~ m@[^\\/]\Z(?!\n)@ &&
1N/A $file =~ m@[^\\/]@
1N/A ) {
1N/A $volume =~ m@([\\/])@ ;
1N/A my $sep = $1 ? $1 : '\\' ;
1N/A $volume .= $sep ;
1N/A }
1N/A
1N/A $volume .= $file ;
1N/A
1N/A return $volume ;
1N/A}
1N/A
1N/A
1N/Asub abs2rel {
1N/A my($self,$path,$base) = @_;
1N/A $base = $self->_cwd() unless defined $base and length $base;
1N/A
1N/A for ($path, $base) { $_ = $self->canonpath($_) }
1N/A
1N/A my ($path_volume) = $self->splitpath($path, 1);
1N/A my ($base_volume) = $self->splitpath($base, 1);
1N/A
1N/A # Can't relativize across volumes
1N/A return $path unless $path_volume eq $base_volume;
1N/A
1N/A for ($path, $base) { $_ = $self->rel2abs($_) }
1N/A
1N/A my $path_directories = ($self->splitpath($path, 1))[1];
1N/A my $base_directories = ($self->splitpath($base, 1))[1];
1N/A
1N/A # Now, remove all leading components that are the same
1N/A my @pathchunks = $self->splitdir( $path_directories );
1N/A my @basechunks = $self->splitdir( $base_directories );
1N/A
1N/A while ( @pathchunks &&
1N/A @basechunks &&
1N/A lc( $pathchunks[0] ) eq lc( $basechunks[0] )
1N/A ) {
1N/A shift @pathchunks ;
1N/A shift @basechunks ;
1N/A }
1N/A
1N/A my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
1N/A
1N/A return $self->canonpath( $self->catpath('', $result_dirs, '') );
1N/A}
1N/A
1N/A
1N/Asub rel2abs {
1N/A my ($self,$path,$base ) = @_;
1N/A
1N/A if ( ! $self->file_name_is_absolute( $path ) ) {
1N/A
1N/A if ( !defined( $base ) || $base eq '' ) {
1N/A $base = $self->_cwd() ;
1N/A }
1N/A elsif ( ! $self->file_name_is_absolute( $base ) ) {
1N/A $base = $self->rel2abs( $base ) ;
1N/A }
1N/A else {
1N/A $base = $self->canonpath( $base ) ;
1N/A }
1N/A
1N/A my ( $path_directories, $path_file ) =
1N/A ($self->splitpath( $path, 1 ))[1,2] ;
1N/A
1N/A my ( $base_volume, $base_directories ) =
1N/A $self->splitpath( $base, 1 ) ;
1N/A
1N/A $path = $self->catpath(
1N/A $base_volume,
1N/A $self->catdir( $base_directories, $path_directories ),
1N/A $path_file
1N/A ) ;
1N/A }
1N/A
1N/A return $self->canonpath( $path ) ;
1N/A}
1N/A
1N/A=back
1N/A
1N/A=head2 Note For File::Spec::Win32 Maintainers
1N/A
1N/ANovell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
1N/A
1N/A=head1 SEE ALSO
1N/A
1N/ASee L<File::Spec> and L<File::Spec::Unix>. This package overrides the
1N/Aimplementation of these methods, not the semantics.
1N/A
1N/A=cut
1N/A
1N/A1;