home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / perl / 5.8.8 / File / Spec / Win32.pm < prev   
Encoding:
Perl POD Document  |  2006-07-07  |  9.1 KB  |  370 lines
  1. package File::Spec::Win32;
  2.  
  3. use strict;
  4.  
  5. use vars qw(@ISA $VERSION);
  6. require File::Spec::Unix;
  7.  
  8. $VERSION = '1.6';
  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. sub rootdir () { '\\' }
  39.  
  40.  
  41. =item tmpdir
  42.  
  43. Returns a string representation of the first existing directory
  44. from the following list:
  45.  
  46.     $ENV{TMPDIR}
  47.     $ENV{TEMP}
  48.     $ENV{TMP}
  49.     SYS:/temp
  50.     C:\system\temp
  51.     C:/temp
  52.     /tmp
  53.     /
  54.  
  55. The SYS:/temp is preferred in Novell NetWare and the C:\system\temp
  56. for Symbian (the File::Spec::Win32 is used also for those platforms).
  57.  
  58. Since Perl 5.8.0, if running under taint mode, and if the environment
  59. variables are tainted, they are not used.
  60.  
  61. =cut
  62.  
  63. my $tmpdir;
  64. sub tmpdir {
  65.     return $tmpdir if defined $tmpdir;
  66.     $tmpdir = $_[0]->_tmpdir( @ENV{qw(TMPDIR TEMP TMP)},
  67.                   'SYS:/temp',
  68.                   'C:\system\temp',
  69.                   'C:/temp',
  70.                   '/tmp',
  71.                   '/'  );
  72. }
  73.  
  74. sub case_tolerant {
  75.     return 1;
  76. }
  77.  
  78. sub file_name_is_absolute {
  79.     my ($self,$file) = @_;
  80.     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  81. }
  82.  
  83. =item catfile
  84.  
  85. Concatenate one or more directory names and a filename to form a
  86. complete path ending with a filename
  87.  
  88. =cut
  89.  
  90. sub catfile {
  91.     my $self = shift;
  92.     my $file = $self->canonpath(pop @_);
  93.     return $file unless @_;
  94.     my $dir = $self->catdir(@_);
  95.     $dir .= "\\" unless substr($dir,-1) eq "\\";
  96.     return $dir.$file;
  97. }
  98.  
  99. sub catdir {
  100.     my $self = shift;
  101.     my @args = @_;
  102.     foreach (@args) {
  103.     tr[/][\\];
  104.         # append a backslash to each argument unless it has one there
  105.         $_ .= "\\" unless m{\\$};
  106.     }
  107.     return $self->canonpath(join('', @args));
  108. }
  109.  
  110. sub path {
  111.     my @path = split(';', $ENV{PATH});
  112.     s/"//g for @path;
  113.     @path = grep length, @path;
  114.     unshift(@path, ".");
  115.     return @path;
  116. }
  117.  
  118. =item canonpath
  119.  
  120. No physical check on the filesystem, but a logical cleanup of a
  121. path. On UNIX eliminated successive slashes and successive "/.".
  122. On Win32 makes 
  123.  
  124.     dir1\dir2\dir3\..\..\dir4 -> \dir\dir4 and even
  125.     dir1\dir2\dir3\...\dir4   -> \dir\dir4
  126.  
  127. =cut
  128.  
  129. sub canonpath {
  130.     my ($self,$path) = @_;
  131.     
  132.     $path =~ s/^([a-z]:)/\u$1/s;
  133.     $path =~ s|/|\\|g;
  134.     $path =~ s|([^\\])\\+|$1\\|g;                  # xx\\\\xx  -> xx\xx
  135.     $path =~ s|(\\\.)+\\|\\|g;                     # xx\.\.\xx -> xx\xx
  136.     $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # .\xx      -> xx
  137.     $path =~ s|\\\Z(?!\n)||
  138.     unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s;  # xx\       -> xx
  139.     # xx1/xx2/xx3/../../xx -> xx1/xx
  140.     $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up
  141.     $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g;    # ...\ is 2 levels up
  142.     return $path if $path =~ m|^\.\.|;      # skip relative paths
  143.     return $path unless $path =~ /\.\./;    # too few .'s to cleanup
  144.     return $path if $path =~ /\.\.\.\./;    # too many .'s to cleanup
  145.     $path =~ s{^\\\.\.$}{\\};                      # \..    -> \
  146.     1 while $path =~ s{^\\\.\.}{};                 # \..\xx -> \xx
  147.  
  148.     return $self->_collapse($path);
  149. }
  150.  
  151. =item splitpath
  152.  
  153.     ($volume,$directories,$file) = File::Spec->splitpath( $path );
  154.     ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file );
  155.  
  156. Splits a path into volume, directory, and filename portions. Assumes that 
  157. the last file is a path unless the path ends in '\\', '\\.', '\\..'
  158. or $no_file is true.  On Win32 this means that $no_file true makes this return 
  159. ( $volume, $path, '' ).
  160.  
  161. Separators accepted are \ and /.
  162.  
  163. Volumes can be drive letters or UNC sharenames (\\server\share).
  164.  
  165. The results can be passed to L</catpath> to get back a path equivalent to
  166. (usually identical to) the original path.
  167.  
  168. =cut
  169.  
  170. sub splitpath {
  171.     my ($self,$path, $nofile) = @_;
  172.     my ($volume,$directory,$file) = ('','','');
  173.     if ( $nofile ) {
  174.         $path =~ 
  175.             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) 
  176.                  (.*)
  177.              }xs;
  178.         $volume    = $1;
  179.         $directory = $2;
  180.     }
  181.     else {
  182.         $path =~ 
  183.             m{^ ( (?: [a-zA-Z]: |
  184.                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
  185.                   )?
  186.                 )
  187.                 ( (?:.*[\\/](?:\.\.?\Z(?!\n))?)? )
  188.                 (.*)
  189.              }xs;
  190.         $volume    = $1;
  191.         $directory = $2;
  192.         $file      = $3;
  193.     }
  194.  
  195.     return ($volume,$directory,$file);
  196. }
  197.  
  198.  
  199. =item splitdir
  200.  
  201. The opposite of L<catdir()|File::Spec/catdir()>.
  202.  
  203.     @dirs = File::Spec->splitdir( $directories );
  204.  
  205. $directories must be only the directory portion of the path on systems 
  206. that have the concept of a volume or that have path syntax that differentiates
  207. files from directories.
  208.  
  209. Unlike just splitting the directories on the separator, leading empty and 
  210. trailing directory entries can be returned, because these are significant
  211. on some OSs. So,
  212.  
  213.     File::Spec->splitdir( "/a/b/c" );
  214.  
  215. Yields:
  216.  
  217.     ( '', 'a', 'b', '', 'c', '' )
  218.  
  219. =cut
  220.  
  221. sub splitdir {
  222.     my ($self,$directories) = @_ ;
  223.     #
  224.     # split() likes to forget about trailing null fields, so here we
  225.     # check to be sure that there will not be any before handling the
  226.     # simple case.
  227.     #
  228.     if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
  229.         return split( m|[\\/]|, $directories );
  230.     }
  231.     else {
  232.         #
  233.         # since there was a trailing separator, add a file name to the end, 
  234.         # then do the split, then replace it with ''.
  235.         #
  236.         my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
  237.         $directories[ $#directories ]= '' ;
  238.         return @directories ;
  239.     }
  240. }
  241.  
  242.  
  243. =item catpath
  244.  
  245. Takes volume, directory and file portions and returns an entire path. Under
  246. Unix, $volume is ignored, and this is just like catfile(). On other OSs,
  247. the $volume become significant.
  248.  
  249. =cut
  250.  
  251. sub catpath {
  252.     my ($self,$volume,$directory,$file) = @_;
  253.  
  254.     # If it's UNC, make sure the glue separator is there, reusing
  255.     # whatever separator is first in the $volume
  256.     my $v;
  257.     $volume .= $v
  258.         if ( (($v) = $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s) &&
  259.              $directory =~ m@^[^\\/]@s
  260.            ) ;
  261.  
  262.     $volume .= $directory ;
  263.  
  264.     # If the volume is not just A:, make sure the glue separator is 
  265.     # there, reusing whatever separator is first in the $volume if possible.
  266.     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
  267.          $volume =~ m@[^\\/]\Z(?!\n)@      &&
  268.          $file   =~ m@[^\\/]@
  269.        ) {
  270.         $volume =~ m@([\\/])@ ;
  271.         my $sep = $1 ? $1 : '\\' ;
  272.         $volume .= $sep ;
  273.     }
  274.  
  275.     $volume .= $file ;
  276.  
  277.     return $volume ;
  278. }
  279.  
  280.  
  281. sub abs2rel {
  282.     my($self,$path,$base) = @_;
  283.     $base = $self->_cwd() unless defined $base and length $base;
  284.  
  285.     for ($path, $base) { $_ = $self->canonpath($_) }
  286.  
  287.     my ($path_volume) = $self->splitpath($path, 1);
  288.     my ($base_volume) = $self->splitpath($base, 1);
  289.  
  290.     # Can't relativize across volumes
  291.     return $path unless $path_volume eq $base_volume;
  292.  
  293.     for ($path, $base) { $_ = $self->rel2abs($_) }
  294.  
  295.     my $path_directories = ($self->splitpath($path, 1))[1];
  296.     my $base_directories = ($self->splitpath($base, 1))[1];
  297.  
  298.     # Now, remove all leading components that are the same
  299.     my @pathchunks = $self->splitdir( $path_directories );
  300.     my @basechunks = $self->splitdir( $base_directories );
  301.  
  302.     while ( @pathchunks && 
  303.             @basechunks && 
  304.             lc( $pathchunks[0] ) eq lc( $basechunks[0] ) 
  305.           ) {
  306.         shift @pathchunks ;
  307.         shift @basechunks ;
  308.     }
  309.  
  310.     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
  311.  
  312.     return $self->canonpath( $self->catpath('', $result_dirs, '') );
  313. }
  314.  
  315.  
  316. sub rel2abs {
  317.     my ($self,$path,$base ) = @_;
  318.  
  319.     if ( ! $self->file_name_is_absolute( $path ) ) {
  320.  
  321.         if ( !defined( $base ) || $base eq '' ) {
  322.         require Cwd ;
  323.         $base = Cwd::getdcwd( ($self->splitpath( $path ))[0] ) if defined &Cwd::getdcwd ;
  324.         $base = $self->_cwd() unless defined $base ;
  325.         }
  326.         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  327.             $base = $self->rel2abs( $base ) ;
  328.         }
  329.         else {
  330.             $base = $self->canonpath( $base ) ;
  331.         }
  332.  
  333.         my ( $path_directories, $path_file ) =
  334.             ($self->splitpath( $path, 1 ))[1,2] ;
  335.  
  336.         my ( $base_volume, $base_directories ) =
  337.             $self->splitpath( $base, 1 ) ;
  338.  
  339.         $path = $self->catpath( 
  340.             $base_volume, 
  341.             $self->catdir( $base_directories, $path_directories ), 
  342.             $path_file
  343.         ) ;
  344.     }
  345.  
  346.     return $self->canonpath( $path ) ;
  347. }
  348.  
  349. =back
  350.  
  351. =head2 Note For File::Spec::Win32 Maintainers
  352.  
  353. Novell NetWare inherits its File::Spec behaviour from File::Spec::Win32.
  354.  
  355. =head1 COPYRIGHT
  356.  
  357. Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
  358.  
  359. This program is free software; you can redistribute it and/or modify
  360. it under the same terms as Perl itself.
  361.  
  362. =head1 SEE ALSO
  363.  
  364. See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
  365. implementation of these methods, not the semantics.
  366.  
  367. =cut
  368.  
  369. 1;
  370.