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