/perl/lib/File/Spec/Win32.pm
Perl | 444 lines | 362 code | 64 blank | 18 comment | 17 complexity | 785f3c54c771c9eb35ae37f637045135 MD5 | raw file
- package File::Spec::Win32;
- use strict;
- use vars qw(@ISA $VERSION);
- require File::Spec::Unix;
- $VERSION = '3.30';
- $VERSION = eval $VERSION;
- @ISA = qw(File::Spec::Unix);
- # Some regexes we use for path splitting
- my $DRIVE_RX = '[a-zA-Z]:';
- my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
- my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
- =head1 NAME
- File::Spec::Win32 - methods for Win32 file specs
- =head1 SYNOPSIS
- require File::Spec::Win32; # Done internally by File::Spec if needed
- =head1 DESCRIPTION
- See File::Spec::Unix for a documentation of the methods provided
- there. This package overrides the implementation of these methods, not
- the semantics.
- =over 4
- =item devnull
- Returns a string representation of the null device.
- =cut
- sub devnull {
- return "nul";
- }
- sub rootdir { '\\' }
- =item tmpdir
- Returns a string representation of the first existing directory
- from the following list:
- $ENV{TMPDIR}
- $ENV{TEMP}
- $ENV{TMP}
- SYS:/temp
- C:\system\temp
- C:/temp
- /tmp
- /
- The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
- for Symbian (the File::Spec::Win32 is used also for those platforms).
- Since Perl 5.8.0, if running under taint mode, and if the environment
- variables are tainted, they are not used.
- =cut
- my $tmpdir;
- sub tmpdir {
- return $tmpdir if defined $tmpdir;
- $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
- 'SYS:/temp',
- 'C:\system\temp',
- 'C:/temp',
- '/tmp',
- '/' );
- }
- =item case_tolerant
- MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
- indicating the case significance when comparing file specifications.
- Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
- See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
- Default: 1
- =cut
- sub case_tolerant {
- eval { require Win32API::File; } or return 1;
- my $drive = shift || "C:";
- my $osFsType = "\0"x256;
- my $osVolName = "\0"x256;
- my $ouFsFlags = 0;
- Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
- if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
- else { return 1; }
- }
- =item file_name_is_absolute
- As of right now, this returns 2 if the path is absolute with a
- volume, 1 if it's absolute with no volume, 0 otherwise.
- =cut
- sub file_name_is_absolute {
- my ($self,$file) = @_;
- if ($file =~ m{^($VOL_RX)}o) {
- my $vol = $1;
- return ($vol =~ m{^$UNC_RX}o ? 2
- : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
- : 0);
- }
- return $file =~ m{^[\\/]} ? 1 : 0;
- }
- =item catfile
- Concatenate one or more directory names and a filename to form a
- complete path ending with a filename
- =cut
- sub catfile {
- shift;
- # Legacy / compatibility support
- #
- shift, return _canon_cat( "/", @_ )
- if $_[0] eq "";
- # Compatibility with File::Spec <= 3.26:
- # catfile('A:', 'foo') should return 'A:\foo'.
- return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
- if $_[0] =~ m{^$DRIVE_RX\z}o;
- return _canon_cat( @_ );
- }
- sub catdir {
- shift;
- # Legacy / compatibility support
- #
- return ""
- unless @_;
- shift, return _canon_cat( "/", @_ )
- if $_[0] eq "";
- # Compatibility with File::Spec <= 3.26:
- # catdir('A:', 'foo') should return 'A:\foo'.
- return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
- if $_[0] =~ m{^$DRIVE_RX\z}o;
- return _canon_cat( @_ );
- }
- sub path {
- my @path = split(';', $ENV{PATH});
- s/"//g for @path;
- @path = grep length, @path;
- unshift(@path, ".");
- return @path;
- }
- =item canonpath
- No physical check on the filesystem, but a logical cleanup of a
- path. On UNIX eliminated successive slashes and successive "/.".
- On Win32 makes
- dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
- dir1\dir2\dir3\...\dir4 -> \dir\dir4
- =cut
- sub canonpath {
- # Legacy / compatibility support
- #
- return $_[1] if !defined($_[1]) or $_[1] eq '';
- return _canon_cat( $_[1] );
- }
- =item splitpath
- ($volume,$directories,$file) = File::Spec->splitpath( $path );
- ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
- Splits a path into 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, '' ).
- Separators accepted are \ and /.
- Volumes can be drive letters or UNC sharenames (\\server\share).
- The results can be passed to L</catpath> 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{^ ( $VOL_RX ? ) (.*) }sox;
- $volume = $1;
- $directory = $2;
- }
- else {
- $path =~
- m{^ ( $VOL_RX ? )
- ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
- (.*)
- }sox;
- $volume = $1;
- $directory = $2;
- $file = $3;
- }
- return ($volume,$directory,$file);
- }
- =item splitdir
- The opposite of L<catdir()|File::Spec/catdir()>.
- @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() likes to forget about trailing null fields, so here we
- # check to be sure that there will not be any before handling the
- # simple case.
- #
- if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
- return split( m|[\\/]|, $directories );
- }
- else {
- #
- # since there was a trailing separator, add a file name to the end,
- # then do the split, then replace it with ''.
- #
- my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
- $directories[ $#directories ]= '' ;
- return @directories ;
- }
- }
- =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
- my $v;
- $volume .= $v
- if ( (($v) = $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 _same {
- lc($_[1]) eq lc($_[2]);
- }
- sub rel2abs {
- my ($self,$path,$base ) = @_;
- my $is_abs = $self->file_name_is_absolute($path);
- # Check for volume (should probably document the '2' thing...)
- return $self->canonpath( $path ) if $is_abs == 2;
- if ($is_abs) {
- # It's missing a volume, add one
- my $vol = ($self->splitpath( $self->_cwd() ))[0];
- return $self->canonpath( $vol . $path );
- }
- if ( !defined( $base ) || $base eq '' ) {
- require Cwd ;
- $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
- $base = $self->_cwd() unless defined $base ;
- }
- 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 ) ;
- }
- =back
- =head2 Note For File::Spec::Win32 Maintainers
- Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
- =head1 COPYRIGHT
- Copyright (c) 2004,2007 by the Perl 5 Porters. All rights reserved.
- This program is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
- =head1 SEE ALSO
- See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
- implementation of these methods, not the semantics.
- =cut
- sub _canon_cat # @path -> path
- {
- my ($first, @rest) = @_;
- my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter
- ? ucfirst( $1 ).( $2 ? "\\" : "" )
- : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
- (?: [\\/] ([^\\/]+) )?
- [\\/]? }{}xs # UNC volume
- ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
- : $first =~ s{ \A [\\/] }{}x # root dir
- ? "\\"
- : "";
- my $path = join "\\", $first, @rest;
- $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy
- # xx/././yy --> xx/yy
- $path =~ s{(?:
- (?:\A|\\) # at begin or after a slash
- \.
- (?:\\\.)* # and more
- (?:\\|\z) # at end or followed by slash
- )+ # performance boost -- I do not know why
- }{\\}gx;
- # XXX I do not know whether more dots are supported by the OS supporting
- # this ... annotation (NetWare or symbian but not MSWin32).
- # Then .... could easily become ../../.. etc:
- # Replace \.\.\. by (\.\.\.+) and substitute with
- # { $1 . ".." . "\\.." x (length($2)-2) }gex
- # ... --> ../..
- $path =~ s{ (\A|\\) # at begin or after a slash
- \.\.\.
- (?=\\|\z) # at end or followed by slash
- }{$1..\\..}gx;
- # xx\yy\..\zz --> xx\zz
- while ( $path =~ s{(?:
- (?:\A|\\) # at begin or after a slash
- [^\\]+ # rip this 'yy' off
- \\\.\.
- (?<!\A\.\.\\\.\.) # do *not* replace ^..\..
- (?<!\\\.\.\\\.\.) # do *not* replace \..\..
- (?:\\|\z) # at end or followed by slash
- )+ # performance boost -- I do not know why
- }{\\}sx ) {}
- $path =~ s#\A\\##; # \xx --> xx NOTE: this is *not* root
- $path =~ s#\\\z##; # xx\ --> xx
- if ( $volume =~ m#\\\z# )
- { # <vol>\.. --> <vol>\
- $path =~ s{ \A # at begin
- \.\.
- (?:\\\.\.)* # and more
- (?:\\|\z) # at end or followed by slash
- }{}x;
- return $1 # \\HOST\SHARE\ --> \\HOST\SHARE
- if $path eq ""
- and $volume =~ m#\A(\\\\.*)\\\z#s;
- }
- return $path ne "" || $volume ? $volume.$path : ".";
- }
- 1;