local-lib5/lib/perl5/i486-linux-gnu-thread-multi/File/Spec/Win32.pm

   1 package File::Spec::Win32;
   2
   3 use strict;
   4
   5 use vars qw(@ISA $VERSION);
   6 require File::Spec::Unix;
   7
   8 $VERSION = '3.30';
   9 $VERSION = eval $VERSION;
  10
  11 @ISA = qw(File::Spec::Unix);
  12
  13 # Some regexes we use for path splitting
  14 my $DRIVE_RX = '[a-zA-Z]:';
  15 my $UNC_RX = '(?:\\\\\\\\|//)[^\\\\/]+[\\\\/][^\\\\/]+';
  16 my $VOL_RX = "(?:$DRIVE_RX|$UNC_RX)";
  17
  18
  19 =head1 NAME
  20
  21 File::Spec::Win32 - methods for Win32 file specs
  22
  23 =head1 SYNOPSIS
  24
  25  require File::Spec::Win32; # Done internally by File::Spec if needed
  26
  27 =head1 DESCRIPTION
  28
  29 See File::Spec::Unix for a documentation of the methods provided
  30 there. This package overrides the implementation of these methods, not
  31 the semantics.
  32
  33 =over 4
  34
  35 =item devnull
  36
  37 Returns a string representation of the null device.
  38
  39 =cut
  40
  41 sub devnull {
  42     return "nul";
  43 }
  44
  45 sub rootdir { '\\' }
  46
  47
  48 =item tmpdir
  49
  50 Returns a string representation of the first existing directory
  51 from the following list:
  52
  53     $ENV{TMPDIR}
  54     $ENV{TEMP}
  55     $ENV{TMP}
  56     SYS:/temp
  57     C:\system\temp
  58     C:/temp
  59     /tmp
  60     /
  61
  62 The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
  63 for Symbian (the File::Spec::Win32 is used also for those platforms).
  64
  65 Since Perl 5.8.0, if running under taint mode, and if the environment
  66 variables are tainted, they are not used.
  67
  68 =cut
  69
  70 my $tmpdir;
  71 sub tmpdir {
  72     return $tmpdir if defined $tmpdir;
  73     $tmpdir = $_[0]->_tmpdir( map( $ENV{$_}, qw(TMPDIR TEMP TMP) ),
  74                               'SYS:/temp',
  75                               'C:\system\temp',
  76                               'C:/temp',
  77                               '/tmp',
  78                               '/'  );
  79 }
  80
  81 =item case_tolerant
  82
  83 MSWin32 case-tolerance depends on GetVolumeInformation() $ouFsFlags == FS_CASE_SENSITIVE,
  84 indicating the case significance when comparing file specifications.
  85 Since XP FS_CASE_SENSITIVE is effectively disabled for the NT subsubsystem.
  86 See http://cygwin.com/ml/cygwin/2007-07/msg00891.html
  87 Default: 1
  88
  89 =cut
  90
  91 sub case_tolerant {
  92   eval { require Win32API::File; } or return 1;
  93   my $drive = shift || "C:";
  94   my $osFsType = "\0"x256;
  95   my $osVolName = "\0"x256;
  96   my $ouFsFlags = 0;
  97   Win32API::File::GetVolumeInformation($drive, $osVolName, 256, [], [], $ouFsFlags, $osFsType, 256 );
  98   if ($ouFsFlags & Win32API::File::FS_CASE_SENSITIVE()) { return 0; }
  99   else { return 1; }
 100 }
 101
 102 =item file_name_is_absolute
 103
 104 As of right now, this returns 2 if the path is absolute with a
 105 volume, 1 if it's absolute with no volume, 0 otherwise.
 106
 107 =cut
 108
 109 sub file_name_is_absolute {
 110
 111     my ($self,$file) = @_;
 112
 113     if ($file =~ m{^($VOL_RX)}o) {
 114       my $vol = $1;
 115       return ($vol =~ m{^$UNC_RX}o ? 2
 116               : $file =~ m{^$DRIVE_RX[\\/]}o ? 2
 117               : 0);
 118     }
 119     return $file =~  m{^[\\/]} ? 1 : 0;
 120 }
 121
 122 =item catfile
 123
 124 Concatenate one or more directory names and a filename to form a
 125 complete path ending with a filename
 126
 127 =cut
 128
 129 sub catfile {
 130     shift;
 131
 132     # Legacy / compatibility support
 133     #
 134     shift, return _canon_cat( "/", @_ )
 135         if $_[0] eq "";
 136
 137     # Compatibility with File::Spec <= 3.26:
 138     #     catfile('A:', 'foo') should return 'A:\foo'.
 139     return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
 140         if $_[0] =~ m{^$DRIVE_RX\z}o;
 141
 142     return _canon_cat( @_ );
 143 }
 144
 145 sub catdir {
 146     shift;
 147
 148     # Legacy / compatibility support
 149     #
 150     return ""
 151         unless @_;
 152     shift, return _canon_cat( "/", @_ )
 153         if $_[0] eq "";
 154
 155     # Compatibility with File::Spec <= 3.26:
 156     #     catdir('A:', 'foo') should return 'A:\foo'.
 157     return _canon_cat( ($_[0].'\\'), @_[1..$#_] )
 158         if $_[0] =~ m{^$DRIVE_RX\z}o;
 159
 160     return _canon_cat( @_ );
 161 }
 162
 163 sub path {
 164     my @path = split(';', $ENV{PATH});
 165     s/"//g for @path;
 166     @path = grep length, @path;
 167     unshift(@path, ".");
 168     return @path;
 169 }
 170
 171 =item canonpath
 172
 173 No physical check on the filesystem, but a logical cleanup of a
 174 path. On UNIX eliminated successive slashes and successive "/.".
 175 On Win32 makes
 176
 177         dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
 178         dir1\dir2\dir3\...\dir4   -> \dir\dir4
 179
 180 =cut
 181
 182 sub canonpath {
 183     # Legacy / compatibility support
 184     #
 185     return $_[1] if !defined($_[1]) or $_[1] eq '';
 186     return _canon_cat( $_[1] );
 187 }
 188
 189 =item splitpath
 190
 191     ($volume,$directories,$file) = File::Spec->splitpath( $path );
 192     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
 193
 194 Splits a path into volume, directory, and filename portions. Assumes that
 195 the last file is a path unless the path ends in '\\', '\\.', '\\..'
 196 or $no_file is true.  On Win32 this means that $no_file true makes this return
 197 ( $volume, $path, '' ).
 198
 199 Separators accepted are \ and /.
 200
 201 Volumes can be drive letters or UNC sharenames (\\server\share).
 202
 203 The results can be passed to L</catpath> to get back a path equivalent to
 204 (usually identical to) the original path.
 205
 206 =cut
 207
 208 sub splitpath {
 209     my ($self,$path, $nofile) = @_;
 210     my ($volume,$directory,$file) = ('','','');
 211     if ( $nofile ) {
 212         $path =~
 213             m{^ ( $VOL_RX ? ) (.*) }sox;
 214         $volume    = $1;
 215         $directory = $2;
 216     }
 217     else {
 218         $path =~
 219             m{^ ( $VOL_RX ? )
 220                 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
 221                 (.*)
 222              }sox;
 223         $volume    = $1;
 224         $directory = $2;
 225         $file      = $3;
 226     }
 227
 228     return ($volume,$directory,$file);
 229 }
 230
 231
 232 =item splitdir
 233
 234 The opposite of L<catdir()|File::Spec/catdir()>.
 235
 236     @dirs = File::Spec->splitdir( $directories );
 237
 238 $directories must be only the directory portion of the path on systems
 239 that have the concept of a volume or that have path syntax that differentiates
 240 files from directories.
 241
 242 Unlike just splitting the directories on the separator, leading empty and
 243 trailing directory entries can be returned, because these are significant
 244 on some OSs. So,
 245
 246     File::Spec->splitdir( "/a/b/c" );
 247
 248 Yields:
 249
 250     ( '', 'a', 'b', '', 'c', '' )
 251
 252 =cut
 253
 254 sub splitdir {
 255     my ($self,$directories) = @_ ;
 256     #
 257     # split() likes to forget about trailing null fields, so here we
 258     # check to be sure that there will not be any before handling the
 259     # simple case.
 260     #
 261     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
 262         return split( m|[\\/]|, $directories );
 263     }
 264     else {
 265         #
 266         # since there was a trailing separator, add a file name to the end,
 267         # then do the split, then replace it with ''.
 268         #
 269         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
 270         $directories[ $#directories ]= '' ;
 271         return @directories ;
 272     }
 273 }
 274
 275
 276 =item catpath
 277
 278 Takes volume, directory and file portions and returns an entire path. Under
 279 Unix, $volume is ignored, and this is just like catfile(). On other OSs,
 280 the $volume become significant.
 281
 282 =cut
 283
 284 sub catpath {
 285     my ($self,$volume,$directory,$file) = @_;
 286
 287     # If it's UNC, make sure the glue separator is there, reusing
 288     # whatever separator is first in the $volume
 289     my $v;
 290     $volume .= $v
 291         if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
 292              $directory =~ m@^[^\\/]@s
 293            ) ;
 294
 295     $volume .= $directory ;
 296
 297     # If the volume is not just A:, make sure the glue separator is
 298     # there, reusing whatever separator is first in the $volume if possible.
 299     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
 300          $volume =~ m@[^\\/]\Z(?!\n)@      &&
 301          $file   =~ m@[^\\/]@
 302        ) {
 303         $volume =~ m@([\\/])@ ;
 304         my $sep = $1 ? $1 : '\\' ;
 305         $volume .= $sep ;
 306     }
 307
 308     $volume .= $file ;
 309
 310     return $volume ;
 311 }
 312
 313 sub _same {
 314   lc($_[1]) eq lc($_[2]);
 315 }
 316
 317 sub rel2abs {
 318     my ($self,$path,$base ) = @_;
 319
 320     my $is_abs = $self->file_name_is_absolute($path);
 321
 322     # Check for volume (should probably document the '2' thing...)
 323     return $self->canonpath( $path ) if $is_abs == 2;
 324
 325     if ($is_abs) {
 326       # It's missing a volume, add one
 327       my $vol = ($self->splitpath( $self->_cwd() ))[0];
 328       return $self->canonpath( $vol . $path );
 329     }
 330
 331     if ( !defined( $base ) || $base eq '' ) {
 332       require Cwd ;
 333       $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
 334       $base = $self->_cwd() unless defined $base ;
 335     }
 336     elsif ( ! $self->file_name_is_absolute( $base ) ) {
 337       $base = $self->rel2abs( $base ) ;
 338     }
 339     else {
 340       $base = $self->canonpath( $base ) ;
 341     }
 342
 343     my ( $path_directories, $path_file ) =
 344       ($self->splitpath( $path, 1 ))[1,2] ;
 345
 346     my ( $base_volume, $base_directories ) =
 347       $self->splitpath( $base, 1 ) ;
 348
 349     $path = $self->catpath(
 350                            $base_volume,
 351                            $self->catdir( $base_directories, $path_directories ),
 352                            $path_file
 353                           ) ;
 354
 355     return $self->canonpath( $path ) ;
 356 }
 357
 358 =back
 359
 360 =head2 Note For File::Spec::Win32 Maintainers
 361
 362 Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
 363
 364 =head1 COPYRIGHT
 365
 366 Copyright (c) 2004,2007 by the Perl 5 Porters.  All rights reserved.
 367
 368 This program is free software; you can redistribute it and/or modify
 369 it under the same terms as Perl itself.
 370
 371 =head1 SEE ALSO
 372
 373 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
 374 implementation of these methods, not the semantics.
 375
 376 =cut
 377
 378
 379 sub _canon_cat                          # @path -> path
 380 {
 381     my ($first, @rest) = @_;
 382
 383     my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x      # drive letter
 384                ? ucfirst( $1 ).( $2 ? "\\" : "" )
 385                : $first =~ s{ \A (?:\\\\|//) ([^\\/]+)
 386                                  (?: [\\/] ([^\\/]+) )?
 387                                  [\\/]? }{}xs                   # UNC volume
 388                ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\"
 389                : $first =~ s{ \A [\\/] }{}x                     # root dir
 390                ? "\\"
 391                : "";
 392     my $path   = join "\\", $first, @rest;
 393
 394     $path =~ tr#\\/#\\\\#s;             # xx/yy --> xx\yy & xx\\yy --> xx\yy
 395
 396                                         # xx/././yy --> xx/yy
 397     $path =~ s{(?:
 398                 (?:\A|\\)               # at begin or after a slash
 399                 \.
 400                 (?:\\\.)*               # and more
 401                 (?:\\|\z)               # at end or followed by slash
 402                )+                       # performance boost -- I do not know why
 403              }{\\}gx;
 404
 405     # XXX I do not know whether more dots are supported by the OS supporting
 406     #     this ... annotation (NetWare or symbian but not MSWin32).
 407     #     Then .... could easily become ../../.. etc:
 408     # Replace \.\.\. by (\.\.\.+)  and substitute with
 409     # { $1 . ".." . "\\.." x (length($2)-2) }gex
 410                                         # ... --> ../..
 411     $path =~ s{ (\A|\\)                 # at begin or after a slash
 412                 \.\.\.
 413                 (?=\\|\z)               # at end or followed by slash
 414              }{$1..\\..}gx;
 415                                         # xx\yy\..\zz --> xx\zz
 416     while ( $path =~ s{(?:
 417                 (?:\A|\\)               # at begin or after a slash
 418                 [^\\]+                  # rip this 'yy' off
 419                 \\\.\.
 420                 (?<!\A\.\.\\\.\.)       # do *not* replace ^..\..
 421                 (?<!\\\.\.\\\.\.)       # do *not* replace \..\..
 422                 (?:\\|\z)               # at end or followed by slash
 423                )+                       # performance boost -- I do not know why
 424              }{\\}sx ) {}
 425
 426     $path =~ s#\A\\##;                  # \xx --> xx  NOTE: this is *not* root
 427     $path =~ s#\\\z##;                  # xx\ --> xx
 428
 429     if ( $volume =~ m#\\\z# )
 430     {                                   # <vol>\.. --> <vol>\
 431         $path =~ s{ \A                  # at begin
 432                     \.\.
 433                     (?:\\\.\.)*         # and more
 434                     (?:\\|\z)           # at end or followed by slash
 435                  }{}x;
 436
 437         return $1                       # \\HOST\SHARE\ --> \\HOST\SHARE
 438             if    $path eq ""
 439               and $volume =~ m#\A(\\\\.*)\\\z#s;
 440     }
 441     return $path ne "" || $volume ? $volume.$path : ".";
 442 }
 443
 444 1;