home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2006 December / PCpro_2006_12.ISO / ossdvd / server / Perl2 / lib / File / Spec / Win32.pm < prev   
Encoding:
Perl POD Document  |  2002-06-19  |  9.3 KB  |  371 lines
  1. package File::Spec::Win32;
  2.  
  3. use strict;
  4. use Cwd;
  5. use vars qw(@ISA $VERSION);
  6. require File::Spec::Unix;
  7.  
  8. $VERSION = '1.3';
  9.  
  10. @ISA = qw(File::Spec::Unix);
  11.  
  12. =head1 NAME
  13.  
  14. File::Spec::Win32 - methods for Win32 file specs
  15.  
  16. =head1 SYNOPSIS
  17.  
  18.  require File::Spec::Win32; # Done internally by File::Spec if needed
  19.  
  20. =head1 DESCRIPTION
  21.  
  22. See File::Spec::Unix for a documentation of the methods provided
  23. there. This package overrides the implementation of these methods, not
  24. the semantics.
  25.  
  26. =over 4
  27.  
  28. =item devnull
  29.  
  30. Returns a string representation of the null device.
  31.  
  32. =cut
  33.  
  34. sub devnull {
  35.     return "nul";
  36. }
  37.  
  38. =item tmpdir
  39.  
  40. Returns a string representation of the first existing directory
  41. from the following list:
  42.  
  43.     $ENV{TMPDIR}
  44.     $ENV{TEMP}
  45.     $ENV{TMP}
  46.     SYS:/temp
  47.     C:/temp
  48.     /tmp
  49.     /
  50.  
  51. The SYS:/temp is preferred in Novell NetWare.
  52.  
  53. Since Perl 5.8.0, if running under taint mode, and if the environment
  54. variables are tainted, they are not used.
  55.  
  56. =cut
  57.  
  58. my $tmpdir;
  59. sub tmpdir {
  60.     return $tmpdir if defined $tmpdir;
  61.     my $self = shift;
  62.     my @dirlist = (@ENV{qw(TMPDIR TEMP TMP)}, qw(C:/temp /tmp /));
  63.     {
  64.     no strict 'refs';
  65.     if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
  66.         require Scalar::Util;
  67.         @dirlist = grep { ! Scalar::Util::tainted $_ } @dirlist;
  68.     }
  69.     }
  70.     foreach (@dirlist) {
  71.     next unless defined && -d;
  72.     $tmpdir = $_;
  73.     last;
  74.     }
  75.     $tmpdir = '' unless defined $tmpdir;
  76.     $tmpdir = $self->canonpath($tmpdir);
  77.     return $tmpdir;
  78. }
  79.  
  80. sub case_tolerant {
  81.     return 1;
  82. }
  83.  
  84. sub file_name_is_absolute {
  85.     my ($self,$file) = @_;
  86.     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  87. }
  88.  
  89. =item catfile
  90.  
  91. Concatenate one or more directory names and a filename to form a
  92. complete path ending with a filename
  93.  
  94. =cut
  95.  
  96. sub catfile {
  97.     my $self = shift;
  98.     my $file = pop @_;
  99.     return $file unless @_;
  100.     my $dir = $self->catdir(@_);
  101.     $dir .= "\\" unless substr($dir,-1) eq "\\";
  102.     return $dir.$file;
  103. }
  104.  
  105. sub path {
  106.     my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
  107.     my @path = split(';',$path);
  108.     foreach (@path) { $_ = '.' if $_ eq '' }
  109.     return @path;
  110. }
  111.  
  112. =item canonpath
  113.  
  114. No physical check on the filesystem, but a logical cleanup of a
  115. path. On UNIX eliminated successive slashes and successive "/.".
  116.  
  117. =cut
  118.  
  119. sub canonpath {
  120.     my ($self,$path) = @_;
  121.     $path =~ s/^([a-z]:)/\u$1/s;
  122.     $path =~ s|/|\\|g;
  123.     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
  124.     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
  125.     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
  126.     $path =~ s|\\\Z(?!\n)||
  127.              unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s;   # xx\       -> xx
  128.     return $path;
  129. }
  130.  
  131. =item splitpath
  132.  
  133.     ($volume,$directories,$file) = File::Spec->splitpath( $path );
  134.     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
  135.  
  136. Splits a path in to volume, directory, and filename portions. Assumes that 
  137. the last file is a path unless the path ends in '\\', '\\.', '\\..'
  138. or $no_file is true.  On Win32 this means that $no_file true makes this return 
  139. ( $volume, $path, undef ).
  140.  
  141. Separators accepted are \ and /.
  142.  
  143. Volumes can be drive letters or UNC sharenames (\\server\share).
  144.  
  145. The results can be passed to L</catpath> to get back a path equivalent to
  146. (usually identical to) the original path.
  147.  
  148. =cut
  149.  
  150. sub splitpath {
  151.     my ($self,$path, $nofile) = @_;
  152.     my ($volume,$directory,$file) = ('','','');
  153.     if ( $nofile ) {
  154.         $path =~ 
  155.             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
  156.                  (.*)
  157.              }xs;
  158.         $volume    = $1;
  159.         $directory = $2;
  160.     }
  161.     else {
  162.         $path =~ 
  163.             m{^ ( (?: [a-zA-Z]: |
  164.                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
  165.                   )?
  166.                 )
  167.                 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
  168.                 (.*)
  169.              }xs;
  170.         $volume    = $1;
  171.         $directory = $2;
  172.         $file      = $3;
  173.     }
  174.  
  175.     return ($volume,$directory,$file);
  176. }
  177.  
  178.  
  179. =item splitdir
  180.  
  181. The opposite of L<catdir()|File::Spec/catdir()>.
  182.  
  183.     @dirs = File::Spec->splitdir( $directories );
  184.  
  185. $directories must be only the directory portion of the path on systems 
  186. that have the concept of a volume or that have path syntax that differentiates
  187. files from directories.
  188.  
  189. Unlike just splitting the directories on the separator, leading empty and 
  190. trailing directory entries can be returned, because these are significant
  191. on some OSs. So,
  192.  
  193.     File::Spec->splitdir( "/a/b/c" );
  194.  
  195. Yields:
  196.  
  197.     ( '', 'a', 'b', '', 'c', '' )
  198.  
  199. =cut
  200.  
  201. sub splitdir {
  202.     my ($self,$directories) = @_ ;
  203.     #
  204.     # split() likes to forget about trailing null fields, so here we
  205.     # check to be sure that there will not be any before handling the
  206.     # simple case.
  207.     #
  208.     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
  209.         return split( m|[\\/]|, $directories );
  210.     }
  211.     else {
  212.         #
  213.         # since there was a trailing separator, add a file name to the end, 
  214.         # then do the split, then replace it with ''.
  215.         #
  216.         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
  217.         $directories[ $#directories ]= '' ;
  218.         return @directories ;
  219.     }
  220. }
  221.  
  222.  
  223. =item catpath
  224.  
  225. Takes volume, directory and file portions and returns an entire path. Under
  226. Unix, $volume is ignored, and this is just like catfile(). On other OSs,
  227. the $volume become significant.
  228.  
  229. =cut
  230.  
  231. sub catpath {
  232.     my ($self,$volume,$directory,$file) = @_;
  233.  
  234.     # If it's UNC, make sure the glue separator is there, reusing
  235.     # whatever separator is first in the $volume
  236.     $volume .= $1
  237.         if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
  238.              $directory =~ m@^[^\\/]@s
  239.            ) ;
  240.  
  241.     $volume .= $directory ;
  242.  
  243.     # If the volume is not just A:, make sure the glue separator is 
  244.     # there, reusing whatever separator is first in the $volume if possible.
  245.     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
  246.          $volume =~ m@[^\\/]\Z(?!\n)@      &&
  247.          $file   =~ m@[^\\/]@
  248.        ) {
  249.         $volume =~ m@([\\/])@ ;
  250.         my $sep = $1 ? $1 : '\\' ;
  251.         $volume .= $sep ;
  252.     }
  253.  
  254.     $volume .= $file ;
  255.  
  256.     return $volume ;
  257. }
  258.  
  259.  
  260. sub abs2rel {
  261.     my($self,$path,$base) = @_;
  262.  
  263.     # Clean up $path
  264.     if ( ! $self->file_name_is_absolute( $path ) ) {
  265.         $path = $self->rel2abs( $path ) ;
  266.     }
  267.     else {
  268.         $path = $self->canonpath( $path ) ;
  269.     }
  270.  
  271.     # Figure out the effective $base and clean it up.
  272.     if ( !defined( $base ) || $base eq '' ) {
  273.         $base = cwd() ;
  274.     }
  275.     elsif ( ! $self->file_name_is_absolute( $base ) ) {
  276.         $base = $self->rel2abs( $base ) ;
  277.     }
  278.     else {
  279.         $base = $self->canonpath( $base ) ;
  280.     }
  281.  
  282.     # Split up paths
  283.     my ( undef, $path_directories, $path_file ) =
  284.         $self->splitpath( $path, 1 ) ;
  285.  
  286.     my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
  287.  
  288.     # Now, remove all leading components that are the same
  289.     my @pathchunks = $self->splitdir( $path_directories );
  290.     my @basechunks = $self->splitdir( $base_directories );
  291.  
  292.     while ( @pathchunks && 
  293.             @basechunks && 
  294.             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
  295.           ) {
  296.         shift @pathchunks ;
  297.         shift @basechunks ;
  298.     }
  299.  
  300.     # No need to catdir, we know these are well formed.
  301.     $path_directories = CORE::join( '\\', @pathchunks );
  302.     $base_directories = CORE::join( '\\', @basechunks );
  303.  
  304.     # $base_directories now contains the directories the resulting relative
  305.     # path must ascend out of before it can descend to $path_directory.  So, 
  306.     # replace all names with $parentDir
  307.  
  308.     #FA Need to replace between backslashes...
  309.     $base_directories =~ s|[^\\]+|..|g ;
  310.  
  311.     # Glue the two together, using a separator if necessary, and preventing an
  312.     # empty result.
  313.  
  314.     #FA Must check that new directories are not empty.
  315.     if ( $path_directories ne '' && $base_directories ne '' ) {
  316.         $path_directories = "$base_directories\\$path_directories" ;
  317.     } else {
  318.         $path_directories = "$base_directories$path_directories" ;
  319.     }
  320.  
  321.     return $self->canonpath( 
  322.         $self->catpath( "", $path_directories, $path_file ) 
  323.     ) ;
  324. }
  325.  
  326.  
  327. sub rel2abs {
  328.     my ($self,$path,$base ) = @_;
  329.  
  330.     if ( ! $self->file_name_is_absolute( $path ) ) {
  331.  
  332.         if ( !defined( $base ) || $base eq '' ) {
  333.             $base = cwd() ;
  334.         }
  335.         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  336.             $base = $self->rel2abs( $base ) ;
  337.         }
  338.         else {
  339.             $base = $self->canonpath( $base ) ;
  340.         }
  341.  
  342.         my ( $path_directories, $path_file ) =
  343.             ($self->splitpath( $path, 1 ))[1,2] ;
  344.  
  345.         my ( $base_volume, $base_directories ) =
  346.             $self->splitpath( $base, 1 ) ;
  347.  
  348.         $path = $self->catpath( 
  349.             $base_volume, 
  350.             $self->catdir( $base_directories, $path_directories ), 
  351.             $path_file
  352.         ) ;
  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 SEE ALSO
  365.  
  366. L<File::Spec>
  367.  
  368. =cut
  369.  
  370. 1;
  371.