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