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 / Unix.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  7.3 KB  |  266 lines
  1. package File::Spec::Unix;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5.  
  6. $VERSION = '3.2501';
  7.  
  8. sub canonpath {
  9.     my ($self,$path) = @_;
  10.     
  11.     # Handle POSIX-style node names beginning with double slash (qnx, nto)
  12.     # (POSIX says: "a pathname that begins with two successive slashes
  13.     # may be interpreted in an implementation-defined manner, although
  14.     # more than two leading slashes shall be treated as a single slash.")
  15.     my $node = '';
  16.     my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
  17.     if ( $double_slashes_special && $path =~ s{^(//[^/]+)(?:/|\z)}{/}s ) {
  18.       $node = $1;
  19.     }
  20.     # This used to be
  21.     # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
  22.     # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
  23.     # (Mainly because trailing "" directories didn't get stripped).
  24.     # Why would cygwin avoid collapsing multiple slashes into one? --jhi
  25.     $path =~ s|/{2,}|/|g;                            # xx////xx  -> xx/xx
  26.     $path =~ s{(?:/\.)+(?:/|\z)}{/}g;                # xx/././xx -> xx/xx
  27.     $path =~ s|^(?:\./)+||s unless $path eq "./";    # ./xx      -> xx
  28.     $path =~ s|^/(?:\.\./)+|/|;                      # /../../xx -> xx
  29.     $path =~ s|^/\.\.$|/|;                         # /..       -> /
  30.     $path =~ s|/\z|| unless $path eq "/";          # xx/       -> xx
  31.     return "$node$path";
  32. }
  33.  
  34. sub catdir {
  35.     my $self = shift;
  36.  
  37.     $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
  38. }
  39.  
  40. sub catfile {
  41.     my $self = shift;
  42.     my $file = $self->canonpath(pop @_);
  43.     return $file unless @_;
  44.     my $dir = $self->catdir(@_);
  45.     $dir .= "/" unless substr($dir,-1) eq "/";
  46.     return $dir.$file;
  47. }
  48.  
  49. sub curdir () { '.' }
  50.  
  51. sub devnull () { '/dev/null' }
  52.  
  53. sub rootdir () { '/' }
  54.  
  55. my $tmpdir;
  56. sub _tmpdir {
  57.     return $tmpdir if defined $tmpdir;
  58.     my $self = shift;
  59.     my @dirlist = @_;
  60.     {
  61.     no strict 'refs';
  62.     if (${"\cTAINT"}) { # Check for taint mode on perl >= 5.8.0
  63.             require Scalar::Util;
  64.         @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
  65.     }
  66.     }
  67.     foreach (@dirlist) {
  68.     next unless defined && -d && -w _;
  69.     $tmpdir = $_;
  70.     last;
  71.     }
  72.     $tmpdir = $self->curdir unless defined $tmpdir;
  73.     $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
  74.     return $tmpdir;
  75. }
  76.  
  77. sub tmpdir {
  78.     return $tmpdir if defined $tmpdir;
  79.     $tmpdir = $_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" );
  80. }
  81.  
  82. sub updir () { '..' }
  83.  
  84. sub no_upwards {
  85.     my $self = shift;
  86.     return grep(!/^\.{1,2}\z/s, @_);
  87. }
  88.  
  89. sub case_tolerant () { 0 }
  90.  
  91. sub file_name_is_absolute {
  92.     my ($self,$file) = @_;
  93.     return scalar($file =~ m:^/:s);
  94. }
  95.  
  96. sub path {
  97.     return () unless exists $ENV{PATH};
  98.     my @path = split(':', $ENV{PATH});
  99.     foreach (@path) { $_ = '.' if $_ eq '' }
  100.     return @path;
  101. }
  102.  
  103. sub join {
  104.     my $self = shift;
  105.     return $self->catfile(@_);
  106. }
  107.  
  108. sub splitpath {
  109.     my ($self,$path, $nofile) = @_;
  110.  
  111.     my ($volume,$directory,$file) = ('','','');
  112.  
  113.     if ( $nofile ) {
  114.         $directory = $path;
  115.     }
  116.     else {
  117.         $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
  118.         $directory = $1;
  119.         $file      = $2;
  120.     }
  121.  
  122.     return ($volume,$directory,$file);
  123. }
  124.  
  125. sub splitdir {
  126.     return split m|/|, $_[1], -1;  # Preserve trailing fields
  127. }
  128.  
  129. sub catpath {
  130.     my ($self,$volume,$directory,$file) = @_;
  131.  
  132.     if ( $directory ne ''                && 
  133.          $file ne ''                     && 
  134.          substr( $directory, -1 ) ne '/' && 
  135.          substr( $file, 0, 1 ) ne '/' 
  136.     ) {
  137.         $directory .= "/$file" ;
  138.     }
  139.     else {
  140.         $directory .= $file ;
  141.     }
  142.  
  143.     return $directory ;
  144. }
  145.  
  146. sub abs2rel {
  147.     my($self,$path,$base) = @_;
  148.     $base = $self->_cwd() unless defined $base and length $base;
  149.  
  150.     ($path, $base) = map $self->canonpath($_), $path, $base;
  151.  
  152.     if (grep $self->file_name_is_absolute($_), $path, $base) {
  153.     ($path, $base) = map $self->rel2abs($_), $path, $base;
  154.     }
  155.     else {
  156.     # save a couple of cwd()s if both paths are relative
  157.     ($path, $base) = map $self->catdir('/', $_), $path, $base;
  158.     }
  159.  
  160.     my ($path_volume) = $self->splitpath($path, 1);
  161.     my ($base_volume) = $self->splitpath($base, 1);
  162.  
  163.     # Can't relativize across volumes
  164.     return $path unless $path_volume eq $base_volume;
  165.  
  166.     my $path_directories = ($self->splitpath($path, 1))[1];
  167.     my $base_directories = ($self->splitpath($base, 1))[1];
  168.  
  169.     # For UNC paths, the user might give a volume like //foo/bar that
  170.     # strictly speaking has no directory portion.  Treat it as if it
  171.     # had the root directory for that volume.
  172.     if (!length($base_directories) and $self->file_name_is_absolute($base)) {
  173.       $base_directories = $self->rootdir;
  174.     }
  175.  
  176.     # Now, remove all leading components that are the same
  177.     my @pathchunks = $self->splitdir( $path_directories );
  178.     my @basechunks = $self->splitdir( $base_directories );
  179.  
  180.     if ($base_directories eq $self->rootdir) {
  181.       shift @pathchunks;
  182.       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
  183.     }
  184.  
  185.     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
  186.         shift @pathchunks ;
  187.         shift @basechunks ;
  188.     }
  189.     return $self->curdir unless @pathchunks || @basechunks;
  190.  
  191.     # $base now contains the directories the resulting relative path 
  192.     # must ascend out of before it can descend to $path_directory.
  193.     my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks );
  194.     return $self->canonpath( $self->catpath('', $result_dirs, '') );
  195. }
  196.  
  197. sub _same {
  198.   $_[1] eq $_[2];
  199. }
  200.  
  201. sub rel2abs {
  202.     my ($self,$path,$base ) = @_;
  203.  
  204.     # Clean up $path
  205.     if ( ! $self->file_name_is_absolute( $path ) ) {
  206.         # Figure out the effective $base and clean it up.
  207.         if ( !defined( $base ) || $base eq '' ) {
  208.         $base = $self->_cwd();
  209.         }
  210.         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  211.             $base = $self->rel2abs( $base ) ;
  212.         }
  213.         else {
  214.             $base = $self->canonpath( $base ) ;
  215.         }
  216.  
  217.         # Glom them together
  218.         $path = $self->catdir( $base, $path ) ;
  219.     }
  220.  
  221.     return $self->canonpath( $path ) ;
  222. }
  223.  
  224. # Internal routine to File::Spec, no point in making this public since
  225. # it is the standard Cwd interface.  Most of the platform-specific
  226. # File::Spec subclasses use this.
  227. sub _cwd {
  228.     require Cwd;
  229.     Cwd::getcwd();
  230. }
  231.  
  232. # Internal method to reduce xx\..\yy -> yy
  233. sub _collapse {
  234.     my($fs, $path) = @_;
  235.  
  236.     my $updir  = $fs->updir;
  237.     my $curdir = $fs->curdir;
  238.  
  239.     my($vol, $dirs, $file) = $fs->splitpath($path);
  240.     my @dirs = $fs->splitdir($dirs);
  241.     pop @dirs if @dirs && $dirs[-1] eq '';
  242.  
  243.     my @collapsed;
  244.     foreach my $dir (@dirs) {
  245.         if( $dir eq $updir              and   # if we have an updir
  246.             @collapsed                  and   # and something to collapse
  247.             length $collapsed[-1]       and   # and its not the rootdir
  248.             $collapsed[-1] ne $updir    and   # nor another updir
  249.             $collapsed[-1] ne $curdir         # nor the curdir
  250.           ) 
  251.         {                                     # then
  252.             pop @collapsed;                   # collapse
  253.         }
  254.         else {                                # else
  255.             push @collapsed, $dir;            # just hang onto it
  256.         }
  257.     }
  258.  
  259.     return $fs->catpath($vol,
  260.                         $fs->catdir(@collapsed),
  261.                         $file
  262.                        );
  263. }
  264.  
  265. 1;
  266.