lib/File/Spec/OS2.pm

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