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