dist/PathTools/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 = '3.64';
   8 $VERSION =~ tr/_//d;
   9
  10 @ISA = qw(File::Spec::Unix);
  11
  12 sub devnull {
  13     return "/dev/nul";
  14 }
  15
  16 sub case_tolerant {
  17     return 1;
  18 }
  19
  20 sub file_name_is_absolute {
  21     my ($self,$file) = @_;
  22     return scalar($file =~ m{^([a-z]:)?[\\/]}is);
  23 }
  24
  25 sub path {
  26     my $path = $ENV{PATH};
  27     $path =~ s:\\:/:g;
  28     my @path = split(';',$path);
  29     foreach (@path) { $_ = '.' if $_ eq '' }
  30     return @path;
  31 }
  32
  33 sub _cwd {
  34     # In OS/2 the "require Cwd" is unnecessary bloat.
  35     return Cwd::sys_cwd();
  36 }
  37
  38 sub tmpdir {
  39     my $cached = $_[0]->_cached_tmpdir(qw 'TMPDIR TEMP TMP');
  40     return $cached if defined $cached;
  41     my @d = @ENV{qw(TMPDIR TEMP TMP)};  # function call could autovivivy
  42     $_[0]->_cache_tmpdir(
  43         $_[0]->_tmpdir( @d, '/tmp', '/' ), qw 'TMPDIR TEMP TMP'
  44     );
  45 }
  46
  47 sub catdir {
  48     my $self = shift;
  49     my @args = @_;
  50     foreach (@args) {
  51         tr[\\][/];
  52         # append a backslash to each argument unless it has one there
  53         $_ .= "/" unless m{/$};
  54     }
  55     return $self->canonpath(join('', @args));
  56 }
  57
  58 sub canonpath {
  59     my ($self,$path) = @_;
  60     return unless defined $path;
  61
  62     $path =~ s/^([a-z]:)/\l$1/s;
  63     $path =~ s|\\|/|g;
  64     $path =~ s|([^/])/+|$1/|g;                  # xx////xx  -> xx/xx
  65     $path =~ s|(/\.)+/|/|g;                     # xx/././xx -> xx/xx
  66     $path =~ s|^(\./)+(?=[^/])||s;              # ./xx      -> xx
  67     $path =~ s|/\Z(?!\n)||
  68              unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/       -> xx
  69     $path =~ s{^/\.\.$}{/};                     # /..    -> /
  70     1 while $path =~ s{^/\.\.}{};               # /../xx -> /xx
  71     return $path;
  72 }
  73
  74
  75 sub splitpath {
  76     my ($self,$path, $nofile) = @_;
  77     my ($volume,$directory,$file) = ('','','');
  78     if ( $nofile ) {
  79         $path =~
  80             m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
  81                  (.*)
  82              }xs;
  83         $volume    = $1;
  84         $directory = $2;
  85     }
  86     else {
  87         $path =~
  88             m{^ ( (?: [a-zA-Z]: |
  89                       (?:\\\\|//)[^\\/]+[\\/][^\\/]+
  90                   )?
  91                 )
  92                 ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
  93                 (.*)
  94              }xs;
  95         $volume    = $1;
  96         $directory = $2;
  97         $file      = $3;
  98     }
  99
 100     return ($volume,$directory,$file);
 101 }
 102
 103
 104 sub splitdir {
 105     my ($self,$directories) = @_ ;
 106     split m|[\\/]|, $directories, -1;
 107 }
 108
 109
 110 sub catpath {
 111     my ($self,$volume,$directory,$file) = @_;
 112
 113     # If it's UNC, make sure the glue separator is there, reusing
 114     # whatever separator is first in the $volume
 115     $volume .= $1
 116         if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\Z(?!\n)@s &&
 117              $directory =~ m@^[^\\/]@s
 118            ) ;
 119
 120     $volume .= $directory ;
 121
 122     # If the volume is not just A:, make sure the glue separator is
 123     # there, reusing whatever separator is first in the $volume if possible.
 124     if ( $volume !~ m@^[a-zA-Z]:\Z(?!\n)@s &&
 125          $volume =~ m@[^\\/]\Z(?!\n)@      &&
 126          $file   =~ m@[^\\/]@
 127        ) {
 128         $volume =~ m@([\\/])@ ;
 129         my $sep = $1 ? $1 : '/' ;
 130         $volume .= $sep ;
 131     }
 132
 133     $volume .= $file ;
 134
 135     return $volume ;
 136 }
 137
 138
 139 sub abs2rel {
 140     my($self,$path,$base) = @_;
 141
 142     # Clean up $path
 143     if ( ! $self->file_name_is_absolute( $path ) ) {
 144         $path = $self->rel2abs( $path ) ;
 145     } else {
 146         $path = $self->canonpath( $path ) ;
 147     }
 148
 149     # Figure out the effective $base and clean it up.
 150     if ( !defined( $base ) || $base eq '' ) {
 151         $base = $self->_cwd();
 152     } elsif ( ! $self->file_name_is_absolute( $base ) ) {
 153         $base = $self->rel2abs( $base ) ;
 154     } else {
 155         $base = $self->canonpath( $base ) ;
 156     }
 157
 158     # Split up paths
 159     my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
 160     my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
 161     return $path unless $path_volume eq $base_volume;
 162
 163     # Now, remove all leading components that are the same
 164     my @pathchunks = $self->splitdir( $path_directories );
 165     my @basechunks = $self->splitdir( $base_directories );
 166
 167     while ( @pathchunks &&
 168             @basechunks &&
 169             lc( $pathchunks[0] ) eq lc( $basechunks[0] )
 170           ) {
 171         shift @pathchunks ;
 172         shift @basechunks ;
 173     }
 174
 175     # No need to catdir, we know these are well formed.
 176     $path_directories = CORE::join( '/', @pathchunks );
 177     $base_directories = CORE::join( '/', @basechunks );
 178
 179     # $base_directories now contains the directories the resulting relative
 180     # path must ascend out of before it can descend to $path_directory.  So,
 181     # replace all names with $parentDir
 182
 183     #FA Need to replace between backslashes...
 184     $base_directories =~ s|[^\\/]+|..|g ;
 185
 186     # Glue the two together, using a separator if necessary, and preventing an
 187     # empty result.
 188
 189     #FA Must check that new directories are not empty.
 190     if ( $path_directories ne '' && $base_directories ne '' ) {
 191         $path_directories = "$base_directories/$path_directories" ;
 192     } else {
 193         $path_directories = "$base_directories$path_directories" ;
 194     }
 195
 196     return $self->canonpath(
 197         $self->catpath( "", $path_directories, $path_file )
 198     ) ;
 199 }
 200
 201
 202 sub rel2abs {
 203     my ($self,$path,$base ) = @_;
 204
 205     if ( ! $self->file_name_is_absolute( $path ) ) {
 206
 207         if ( !defined( $base ) || $base eq '' ) {
 208             $base = $self->_cwd();
 209         }
 210         elsif ( ! $self->file_name_is_absolute( $base ) ) {
 211             $base = $self->rel2abs( $base ) ;
 212         }
 213         else {
 214             $base = $self->canonpath( $base ) ;
 215         }
 216
 217         my ( $path_directories, $path_file ) =
 218             ($self->splitpath( $path, 1 ))[1,2] ;
 219
 220         my ( $base_volume, $base_directories ) =
 221             $self->splitpath( $base, 1 ) ;
 222
 223         $path = $self->catpath(
 224             $base_volume,
 225             $self->catdir( $base_directories, $path_directories ),
 226             $path_file
 227         ) ;
 228     }
 229
 230     return $self->canonpath( $path ) ;
 231 }
 232
 233 1;
 234 __END__
 235
 236 =head1 NAME
 237
 238 File::Spec::OS2 - methods for OS/2 file specs
 239
 240 =head1 SYNOPSIS
 241
 242  require File::Spec::OS2; # Done internally by File::Spec if needed
 243
 244 =head1 DESCRIPTION
 245
 246 See L<File::Spec> and L<File::Spec::Unix>.  This package overrides the
 247 implementation of these methods, not the semantics.
 248
 249 Amongst the changes made for OS/2 are...
 250
 251 =over 4
 252
 253 =item tmpdir
 254
 255 Modifies the list of places temp directory information is looked for.
 256
 257     $ENV{TMPDIR}
 258     $ENV{TEMP}
 259     $ENV{TMP}
 260     /tmp
 261     /
 262
 263 =item splitpath
 264
 265 Volumes can be drive letters or UNC sharenames (\\server\share).
 266
 267 =back
 268
 269 =head1 COPYRIGHT
 270
 271 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
 272
 273 This program is free software; you can redistribute it and/or modify
 274 it under the same terms as Perl itself.
 275
 276 =cut