[Summary view] [Print] [Text view]

   1  package File::Spec::OS2;
   2  
   3  use strict;
   4  use vars qw(@ISA $VERSION);
   5  require File::Spec::Unix;
   6  
   7  $VERSION = '3.2501';
   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