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