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