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