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