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         require Cwd;
 204         $base = Cwd::sys_cwd() ;
 205     } elsif ( ! $self->file_name_is_absolute( $base ) ) {
 206         $base = $self->rel2abs( $base ) ;
 207     } else {
 208         $base = $self->canonpath( $base ) ;
 209     }
 210
 211     # Split up paths
 212     my ( undef, $path_directories, $path_file ) =
 213         $self->splitpath( $path, 1 ) ;
 214
 215     my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
 216
 217     # Now, remove all leading components that are the same
 218     my @pathchunks = $self->splitdir( $path_directories );
 219     my @basechunks = $self->splitdir( $base_directories );
 220
 221     while ( @pathchunks &&
 222             @basechunks &&
 223             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 224           ) {
 225         shift @pathchunks ;
 226         shift @basechunks ;
 227     }
 228
 229     # No need to catdir, we know these are well formed.
 230     $path_directories = CORE::join( '/', @pathchunks );
 231     $base_directories = CORE::join( '/', @basechunks );
 232
 233     # $base_directories now contains the directories the resulting relative
 234     # path must ascend out of before it can descend to $path_directory.  So,
 235     # replace all names with $parentDir
 236
 237     #FA Need to replace between backslashes...
 238     $base_directories =~ s|[^\\/]+|..|g ;
 239
 240     # Glue the two together, using a separator if necessary, and preventing an
 241     # empty result.
 242
 243     #FA Must check that new directories are not empty.
 244     if ( $path_directories ne '' && $base_directories ne '' ) {
 245         $path_directories = "$base_directories/$path_directories" ;
 246     } else {
 247         $path_directories = "$base_directories$path_directories" ;
 248     }
 249
 250     return $self->canonpath(
 251         $self->catpath( "", $path_directories, $path_file )
 252     ) ;
 253 }
 254
 255
 256 sub rel2abs {
 257     my ($self,$path,$base ) = @_;
 258
 259     if ( ! $self->file_name_is_absolute( $path ) ) {
 260
 261         if ( !defined( $base ) || $base eq '' ) {
 262             require Cwd;
 263             $base = Cwd::sys_cwd() ;
 264         }
 265         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 266             $base = $self->rel2abs( $base ) ;
 267         }
 268         else {
 269             $base = $self->canonpath( $base ) ;
 270         }
 271
 272         my ( $path_directories, $path_file ) =
 273             ($self->splitpath( $path, 1 ))[1,2] ;
 274
 275         my ( $base_volume, $base_directories ) =
 276             $self->splitpath( $base, 1 ) ;
 277
 278         $path = $self->catpath(
 279             $base_volume,
 280             $self->catdir( $base_directories, $path_directories ),
 281             $path_file
 282         ) ;
 283     }
 284
 285     return $self->canonpath( $path ) ;
 286 }
 287
 288 1;
 289 __END__
 290
 291 =head1 NAME
 292
 293 File::Spec::OS2 - methods for OS/2 file specs
 294
 295 =head1 SYNOPSIS
 296
 297  require File::Spec::OS2; # Done internally by File::Spec if needed
 298
 299 =head1 DESCRIPTION
 300
 301 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
 302 implementation of these methods, not the semantics.