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