home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / File / Spec / OS2.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  6.6 KB  |  272 lines
  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
  272.