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.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.